148 lines
5.2 KiB
Scheme
148 lines
5.2 KiB
Scheme
;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
;;; Commentary:
|
|
;;;
|
|
;;; Example game showing off several common game programming things.
|
|
;;;
|
|
;;; Code:
|
|
|
|
(use-modules (scheme base)
|
|
(dom document)
|
|
(dom element)
|
|
(dom event)
|
|
(math vector)
|
|
(hoot ffi)
|
|
(hoot hashtables)
|
|
(ice-9 match))
|
|
|
|
|
|
(define *template* '())
|
|
(define (wrap-template template)
|
|
`(div (@ (id "container"))
|
|
(button (@ (click ,(lambda (event)
|
|
(set! *template* template-click)
|
|
(render))))
|
|
"Click")
|
|
(button (@ (click ,(lambda (event)
|
|
(set! *template* template-task)
|
|
(render))))
|
|
"Task")
|
|
(div (@ (id "application")) ,(template))))
|
|
|
|
(define (render)
|
|
(let ((old (get-element-by-id "container")))
|
|
(unless (external-null? old) (remove! old))
|
|
(append-child! (document-body) (sxml->dom (wrap-template *template*)))))
|
|
|
|
(define (sxml->dom exp)
|
|
(match exp
|
|
;; The simple case: a string representing a text node.
|
|
((? string? str)
|
|
(make-text-node str))
|
|
;; An element tree. The first item is the HTML tag.
|
|
(((? symbol? tag) . body)
|
|
;; Create a new element with the given tag.
|
|
(let ((elem (make-element (symbol->string tag))))
|
|
(define (add-children children)
|
|
;; Recursively call sxml->dom for each child node and
|
|
;; append it to elem.
|
|
(for-each (lambda (child)
|
|
(append-child! elem (sxml->dom child)))
|
|
children))
|
|
(match body
|
|
;; '@' denotes an attribute list. Child nodes follow.
|
|
((('@ . attrs) . children)
|
|
;; Set attributes.
|
|
(for-each (lambda (attr)
|
|
(match attr
|
|
;; Attributes are (symbol string) tuples.
|
|
(((? symbol? name) (? string? val))
|
|
(set-attribute! elem
|
|
(symbol->string name)
|
|
val))
|
|
(((? symbol? name) (? boolean? val))
|
|
(set-attribute! elem
|
|
(symbol->string name)
|
|
val))
|
|
(((? symbol? name) (? procedure? proc))
|
|
(add-event-listener! elem
|
|
(symbol->string name)
|
|
(procedure->external proc)))))
|
|
attrs)
|
|
(add-children children))
|
|
;; No attributes, just a list of child nodes.
|
|
(children (add-children children)))
|
|
elem))))
|
|
|
|
;; Click
|
|
(define *clicks* 0)
|
|
(define (template-click)
|
|
`(div
|
|
(p ,(number->string *clicks*) " clicks")
|
|
(button (@ (click ,(lambda (event)
|
|
(set! *clicks* (+ *clicks* 1))
|
|
(render))))
|
|
"Click me!")))
|
|
|
|
;; Task
|
|
(define-record-type <task>
|
|
(make-task name done?)
|
|
task?
|
|
(name task-name)
|
|
(done? task-done? set-task-done!))
|
|
|
|
(define *tasks* '())
|
|
(define (add-task! task)
|
|
(set! *tasks* (cons task *tasks*)))
|
|
(define (remove-task! task)
|
|
(set! *tasks* (delq task *tasks*)))
|
|
|
|
(define (template-task)
|
|
(define (task-template task)
|
|
`(li (input (@ (type "checkbox")
|
|
(change ,(lambda (event)
|
|
(let* ((checkbox (event-target event))
|
|
(checked? (element-checked? checkbox)))
|
|
(set-task-done! task checked?)
|
|
(render))))
|
|
(checked ,(task-done? task))))
|
|
(span (@ (style "padding: 0 1em 0 1em;"))
|
|
,(if (task-done? task)
|
|
`(s ,(task-name task))
|
|
(task-name task)))
|
|
(a (@ (href "#")
|
|
(click ,(lambda (event)
|
|
(remove-task! task)
|
|
(render))))
|
|
"remove")))
|
|
`(div
|
|
(h2 "Tasks")
|
|
;; Tasks are stored in reverse order.
|
|
(ul ,@(map task-template (reverse *tasks*)))
|
|
(input (@ (id "new-task")
|
|
(placeholder "Write more task")))
|
|
;; Add new task on click
|
|
(button (@ (click ,(lambda (event)
|
|
(let* ((input (get-element-by-id "new-task"))
|
|
(name (element-value input)))
|
|
(unless (string=? name "")
|
|
(add-task! (make-task name #f))
|
|
(set-element-value! input "")
|
|
(render))))))
|
|
"Add task")))
|
|
|
|
;; Main
|
|
(set! *template* template-task)
|
|
(render)
|