577 lines
19 KiB
Scheme
577 lines
19 KiB
Scheme
;;; Copyright © 2024 David Thompson <dthompson2@worcester.edu>
|
|
;;; Modifications Copyright © 2024 Vivianne Langdon <puttabutta@gmail.com>
|
|
;;;
|
|
;;; This program is free software: you can redistribute it and/or
|
|
;;; modify it under the terms of the GNU General Public License as
|
|
;;; published by the Free Software Foundation, either version 3 of the
|
|
;;; License, or (at your option) any later version.
|
|
;;;
|
|
;;; This program is distributed in the hope that it will be useful,
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;; General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with this program. If not, see
|
|
;;; <http://www.gnu.org/licenses/>.
|
|
(use-modules (ice-9 match)
|
|
(srfi srfi-9)
|
|
(srfi srfi-9 gnu)
|
|
((hoot hashtables) #:select (make-weak-key-hashtable
|
|
weak-key-hashtable-ref
|
|
weak-key-hashtable-set!))
|
|
((hoot lists) #:select (fold))
|
|
((hoot numbers) #:select (truncate))
|
|
(hoot ffi))
|
|
|
|
(define-foreign timeout
|
|
"window" "setTimeout"
|
|
(ref extern) f64 -> i32)
|
|
|
|
(define-foreign document-body
|
|
"document" "body"
|
|
-> (ref null extern))
|
|
|
|
(define-foreign make-text-node
|
|
"document" "makeTextNode"
|
|
(ref string) -> (ref extern))
|
|
|
|
(define-foreign make-element
|
|
"document" "makeElement"
|
|
(ref string) -> (ref extern))
|
|
|
|
(define-foreign append-child!
|
|
"element" "appendChild"
|
|
(ref extern) (ref extern) -> (ref extern))
|
|
|
|
(define-foreign attribute-set!
|
|
"element" "setAttribute"
|
|
(ref extern) (ref string) (ref string) -> none)
|
|
|
|
(define-foreign value
|
|
"element" "getValue"
|
|
(ref extern) -> (ref string))
|
|
|
|
(define-foreign set-value!
|
|
"element" "setValue"
|
|
(ref extern) (ref string) -> none)
|
|
|
|
(define-foreign add-event-listener!
|
|
"element" "addEventListener"
|
|
(ref extern) (ref string) (ref extern) -> none)
|
|
|
|
(define-foreign replace-with!
|
|
"element" "replaceWith"
|
|
(ref extern) (ref extern) -> none)
|
|
|
|
(define (lset-adjoin = list . rest)
|
|
(define pred
|
|
(if (or (eq? = eq?) (eq? = eqv?))
|
|
=
|
|
(lambda (x y) (= y x))))
|
|
(let lp ((ans list) (rest rest))
|
|
(match rest
|
|
(() ans)
|
|
((x . rest*)
|
|
(lp (if (member x ans pred)
|
|
ans
|
|
(cons x ans))
|
|
rest*)))))
|
|
|
|
(define (any pred lst)
|
|
(let lp ((lst lst))
|
|
(match lst
|
|
(() #f)
|
|
((x . rest)
|
|
(or (pred x) (lp rest))))))
|
|
|
|
(define (every pred lst)
|
|
(let lp ((lst lst))
|
|
(match lst
|
|
(() #t)
|
|
((x . rest)
|
|
(and (pred x) (lp rest))))))
|
|
|
|
(define procedure->external*
|
|
(let ((cache (make-weak-key-hashtable)))
|
|
(lambda (proc)
|
|
(or (weak-key-hashtable-ref cache proc)
|
|
(let ((extern (procedure->external proc)))
|
|
(weak-key-hashtable-set! cache proc extern)
|
|
extern)))))
|
|
(define (queue-task! thunk)
|
|
(timeout (procedure->external* thunk) 0.0))
|
|
|
|
(define-record-type <nothing>
|
|
(make-nothing)
|
|
%nothing?)
|
|
(define (print-nothing nothing port)
|
|
(display "#<nothing>" port))
|
|
(set-record-type-printer! <nothing> print-nothing)
|
|
(define nothing (make-nothing))
|
|
(define (nothing? x) (eq? x nothing))
|
|
|
|
(define-record-type <contradiction>
|
|
(make-contradiction details)
|
|
contradiction?
|
|
(details contradiction-details))
|
|
|
|
(define (print-contradiction contradiction port)
|
|
(format port "#<contradiction ~a>"
|
|
(contradiction-details contradiction)))
|
|
(set-record-type-printer! <contradiction> print-contradiction)
|
|
|
|
(define contradiction (make-contradiction nothing))
|
|
|
|
(define-record-type <relations>
|
|
(%make-relations name parent children)
|
|
relations?
|
|
(name relations-name)
|
|
(parent relations-parent)
|
|
(children relations-children set-relations-children!))
|
|
|
|
(define (print-relations relations port)
|
|
(match relations
|
|
(($ <relations> name parent children)
|
|
(format port "#<relations ~a ↑ ~a ↓ ~a>"
|
|
name parent children))))
|
|
(set-record-type-printer! <relations> print-relations)
|
|
|
|
(define current-parent (make-parameter #f))
|
|
|
|
(define (make-relations name)
|
|
(%make-relations name (current-parent) '()))
|
|
|
|
(define (add-child! parent child)
|
|
(when parent
|
|
(set-relations-children! parent (cons child (relations-children parent)))))
|
|
|
|
(define-record-type <cell>
|
|
(%make-cell relations neighbors content strongest
|
|
equivalent? merge find-strongest handle-contradiction)
|
|
cell?
|
|
(relations cell-relations)
|
|
(neighbors cell-neighbors set-cell-neighbors!)
|
|
(content cell-content set-cell-content!)
|
|
(strongest cell-strongest set-cell-strongest!)
|
|
;; Dispatch table:
|
|
(equivalent? cell-equivalent?)
|
|
(merge cell-merge)
|
|
(find-strongest cell-find-strongest)
|
|
(handle-contradiction cell-handle-contradiction))
|
|
|
|
(define (print-cell cell port)
|
|
(match cell
|
|
(($ <cell> ($ <relations> name) _ _ strongest)
|
|
(display "#<cell " port)
|
|
(display name port)
|
|
(display " " port)
|
|
(display strongest port)
|
|
(display ">" port))))
|
|
(set-record-type-printer! <cell> print-cell)
|
|
|
|
(define-record-type <propagator>
|
|
(%make-propagator relations inputs outputs activate)
|
|
propagator?
|
|
(relations propagator-relations)
|
|
(inputs propagator-inputs)
|
|
(outputs propagator-outputs)
|
|
(activate propagator-activate))
|
|
|
|
(define (print-propagator propagator port)
|
|
(match propagator
|
|
(($ <propagator> ($ <relations> name) inputs outputs)
|
|
(display "#<propagator " port)
|
|
(display name port)
|
|
(display " " port)
|
|
(display inputs port)
|
|
(display " -> " port)
|
|
(display outputs port)
|
|
(display ">" port))))
|
|
(set-record-type-printer! <propagator> print-propagator)
|
|
|
|
(define default-equivalent? equal?)
|
|
;; But what about partial information???
|
|
(define (default-merge old new) new)
|
|
(define (default-find-strongest content) content)
|
|
(define (default-handle-contradiction cell) (values))
|
|
|
|
(define* (make-cell name #:key
|
|
(equivalent? default-equivalent?)
|
|
(merge default-merge)
|
|
(find-strongest default-find-strongest)
|
|
(handle-contradiction default-handle-contradiction))
|
|
(let ((cell (%make-cell (make-relations name) '() nothing nothing
|
|
equivalent? merge find-strongest
|
|
handle-contradiction)))
|
|
(add-child! (current-parent) cell)
|
|
cell))
|
|
|
|
(define (cell-name cell)
|
|
(relations-name (cell-relations cell)))
|
|
|
|
(define (add-cell-neighbor! cell neighbor)
|
|
(set-cell-neighbors! cell (lset-adjoin eq? (cell-neighbors cell) neighbor)))
|
|
|
|
(define (add-cell-content! cell new)
|
|
(match cell
|
|
(($ <cell> _ neighbors content strongest equivalent? merge
|
|
find-strongest handle-contradiction)
|
|
(let ((content* (merge content new)))
|
|
(set-cell-content! cell content*)
|
|
(let ((strongest* (find-strongest content*)))
|
|
(cond
|
|
;; New strongest value is equivalent to the old one. No need
|
|
;; to alert propagators.
|
|
((equivalent? strongest strongest*)
|
|
(set-cell-strongest! cell strongest*))
|
|
;; Uh oh, a contradiction! Call handler.
|
|
((contradiction? strongest*)
|
|
(set-cell-strongest! cell strongest*)
|
|
(handle-contradiction cell))
|
|
;; Strongest value has changed. Alert the propagators!
|
|
(else
|
|
(set-cell-strongest! cell strongest*)
|
|
(for-each alert-propagator! neighbors))))))))
|
|
|
|
(define (alert-propagator! propagator)
|
|
(queue-task! (propagator-activate propagator)))
|
|
|
|
(define (make-propagator name inputs outputs activate)
|
|
(let ((propagator (%make-propagator (make-relations name)
|
|
inputs outputs activate)))
|
|
(add-child! (current-parent) propagator)
|
|
(for-each (lambda (cell)
|
|
(add-cell-neighbor! cell propagator))
|
|
inputs)
|
|
(alert-propagator! propagator)
|
|
propagator))
|
|
|
|
(define (unusable-value? x)
|
|
(or (nothing? x) (contradiction? x)))
|
|
|
|
(define (primitive-propagator name f)
|
|
(match-lambda*
|
|
((inputs ... output)
|
|
(define (activate)
|
|
(let ((args (map cell-strongest inputs)))
|
|
(unless (any unusable-value? args)
|
|
(add-cell-content! output (apply f args)))))
|
|
(make-propagator name inputs (list output) activate))))
|
|
|
|
(define (compound-propagator name inputs outputs build)
|
|
(let ((built? #f))
|
|
(define (maybe-build)
|
|
(unless (or built?
|
|
(and (not (null? inputs))
|
|
(every unusable-value? (map cell-strongest inputs))))
|
|
(parameterize ((current-parent (propagator-relations propagator)))
|
|
(build)
|
|
(set! built? #t))))
|
|
(define propagator (make-propagator name inputs outputs maybe-build))
|
|
propagator))
|
|
|
|
(define (constraint-propagator name cells build)
|
|
(compound-propagator name cells cells build))
|
|
|
|
(define-record-type <reactive-id>
|
|
(%make-reactive-id clock)
|
|
reactive-id?
|
|
(clock reactive-id-clock set-reactive-id-clock!))
|
|
|
|
(define (make-reactive-id)
|
|
(%make-reactive-id 0))
|
|
|
|
(define (reactive-id-tick! id)
|
|
(let ((t (1+ (reactive-id-clock id))))
|
|
(set-reactive-id-clock! id t)
|
|
`((,id . ,t))))
|
|
|
|
;; Partial value structure for FRP
|
|
(define-record-type <ephemeral>
|
|
(make-ephemeral value timestamps)
|
|
ephemeral?
|
|
(value ephemeral-value)
|
|
;; Association list mapping identity -> time
|
|
(timestamps ephemeral-timestamps))
|
|
|
|
(define (ephemeral-fresher? a b)
|
|
(let ((b-inputs (ephemeral-timestamps b)))
|
|
(let lp ((a-inputs (ephemeral-timestamps a)))
|
|
(match a-inputs
|
|
(() #t)
|
|
(((key . a-time) . rest)
|
|
(match (assq-ref b-inputs key)
|
|
(#f (lp rest))
|
|
(b-time
|
|
(and (> a-time b-time)
|
|
(lp rest)))))))))
|
|
|
|
(define (merge-ephemeral-timestamps ephemerals)
|
|
(define (adjoin-keys alist keys)
|
|
(fold (lambda (key+value keys)
|
|
(match key+value
|
|
((key . _)
|
|
(lset-adjoin eq? keys key))))
|
|
keys alist))
|
|
(define (check-timestamps id)
|
|
(let lp ((ephemerals ephemerals) (t #f))
|
|
(match ephemerals
|
|
(() t)
|
|
((($ <ephemeral> _ timestamps) . rest)
|
|
(match (assq-ref timestamps id)
|
|
;; No timestamp for this id in this ephemeral. Continue.
|
|
(#f (lp rest t))
|
|
(t*
|
|
(if t
|
|
;; If timestamps don't match then we have a mix of
|
|
;; fresh and stale values, so return #f. Otherwise,
|
|
;; continue.
|
|
(and (= t t*) (lp rest t))
|
|
;; Initialize timestamp and continue.
|
|
(lp rest t*))))))))
|
|
;; Build a set of all reactive identifiers across all ephemerals.
|
|
(let ((ids (fold (lambda (ephemeral ids)
|
|
(adjoin-keys (ephemeral-timestamps ephemeral) ids))
|
|
'() ephemerals)))
|
|
(let lp ((ids ids) (timestamps '()))
|
|
(match ids
|
|
(() timestamps)
|
|
((id . rest)
|
|
;; Check for consistent timestamps. If they are consistent
|
|
;; then add it to the alist and continue. Otherwise, return
|
|
;; #f.
|
|
(let ((t (check-timestamps id)))
|
|
(and t (lp rest (cons (cons id t) timestamps)))))))))
|
|
|
|
(define (merge-ephemerals old new)
|
|
(cond
|
|
((nothing? old) new)
|
|
((nothing? new) old)
|
|
((ephemeral-fresher? new old) new)
|
|
(else old)))
|
|
|
|
(define (ephemeral-wrap proc)
|
|
(match-lambda*
|
|
((and ephemerals (($ <ephemeral> args) ...))
|
|
(match (merge-ephemeral-timestamps ephemerals)
|
|
(#f nothing)
|
|
(timestamps (make-ephemeral (apply proc args) timestamps))))))
|
|
|
|
(define-record-type <transient>
|
|
(%make-transient cell id)
|
|
transient?
|
|
(cell transient-cell)
|
|
(id transient-id))
|
|
|
|
(define* (make-transient cell #:optional (id (make-reactive-id)))
|
|
(%make-transient cell id))
|
|
|
|
(define (set-trans! transient value)
|
|
(match transient
|
|
(($ <transient> cell id)
|
|
(let ((timestamp (reactive-id-tick! id)))
|
|
(add-cell-content! cell (make-ephemeral value timestamp))))))
|
|
|
|
(define (get-trans transient)
|
|
(ephemeral-value (cell-content (transient-cell transient))))
|
|
|
|
(define* (primitive-reactive-propagator name proc)
|
|
(primitive-propagator name (ephemeral-wrap proc)))
|
|
|
|
(define-syntax-rule (define-primitive name proc)
|
|
(define name (primitive-reactive-propagator 'name proc)))
|
|
|
|
(define-syntax-rule (define-constraint (name cells ...) body ...)
|
|
(define (name cells ...)
|
|
(constraint-propagator
|
|
'name
|
|
(list cells ...)
|
|
(lambda () body ...))))
|
|
|
|
(define-syntax thru
|
|
(syntax-rules (->)
|
|
((thru (inputs ... -> output) body ...)
|
|
(begin
|
|
((primitive-reactive-propagator
|
|
'anonymous-propa
|
|
(lambda (inputs ...) body ...))
|
|
inputs ... output)
|
|
output))
|
|
((thru (inputs ...) body ...)
|
|
(let ((output (make-cell 'anonymous-cell)))
|
|
((primitive-reactive-propagator
|
|
'anonymous-propa
|
|
(lambda (inputs ...) body ...))
|
|
inputs ... output)
|
|
output))))
|
|
|
|
(define (r:attribute input elem attr)
|
|
(let ((attr (symbol->string attr)))
|
|
(define (activate)
|
|
(match (cell-strongest input)
|
|
(($ <ephemeral> val)
|
|
(attribute-set! elem attr (obj->string val)))
|
|
;; Ignore unusable values.
|
|
(_ (values))))
|
|
(make-propagator 'r:attribute (list input) '() activate)))
|
|
|
|
(define-record-type <binding>
|
|
(make-binding trans default numeric? group)
|
|
binding?
|
|
(trans binding-trans)
|
|
(default binding-default)
|
|
(numeric? binding-numeric?)
|
|
(group binding-group))
|
|
|
|
(define* (binding trans #:key (default nothing) (numeric? #f) (group '()))
|
|
(make-binding trans default numeric? group))
|
|
|
|
(define (obj->string obj)
|
|
(if (string? obj)
|
|
obj
|
|
(call-with-output-string
|
|
(lambda (port)
|
|
(write obj port)))))
|
|
|
|
(define (string->obj str)
|
|
(call-with-input-string str read))
|
|
|
|
(define* (r:binding binding elem)
|
|
(match binding
|
|
(($ <binding> ($ <transient> cell id) default numeric? group)
|
|
(define (update new)
|
|
(unless (nothing? new)
|
|
(let* ((timestamp (reactive-id-tick! id)))
|
|
(add-cell-content! cell (make-ephemeral new timestamp))
|
|
;; Freshen timestamps for all cells in the same group.
|
|
(for-each (lambda (other)
|
|
(unless (eq? other cell)
|
|
(match (cell-strongest other)
|
|
(($ <ephemeral> val)
|
|
(add-cell-content! other (make-ephemeral val timestamp)))
|
|
(_ #f))))
|
|
group))))
|
|
;; Sync the element's value with the cell's value.
|
|
(define (activate)
|
|
(match (cell-strongest cell)
|
|
(($ <ephemeral> val)
|
|
(set-value! elem (if numeric? (object->string val) val)))
|
|
(_ (values))))
|
|
;; Initialize element value with the default value.
|
|
(update default)
|
|
;; Sync the cell's value with the element's value.
|
|
(add-event-listener! elem "input"
|
|
(procedure->external
|
|
(lambda (event)
|
|
(update (if numeric? (string->number (value elem)) (value elem))))))
|
|
(make-propagator 'r:binding (list cell) '() activate))))
|
|
|
|
(define (cell->elem cell)
|
|
(let ((exp (cell-strongest cell)))
|
|
(if (unusable-value? exp)
|
|
(make-text-node "")
|
|
(sxml->dom exp))))
|
|
|
|
(define (sxml->dom exp)
|
|
(match exp
|
|
;; The simple case: a string representing a text node.
|
|
((? string? str)
|
|
(make-text-node str))
|
|
((? number? num)
|
|
(make-text-node (number->string num)))
|
|
;; A cell containing SXML (or nothing)
|
|
((? cell? cell)
|
|
(let ((elem (cell->elem cell)))
|
|
(r:dom cell elem)
|
|
elem))
|
|
;; 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
|
|
((('@ . attrs) . children)
|
|
(for-each (lambda (attr)
|
|
(match attr
|
|
(((? symbol? name) (? string? val))
|
|
(attribute-set! elem
|
|
(symbol->string name)
|
|
val))
|
|
(((? symbol? name) (? number? val))
|
|
(attribute-set! elem
|
|
(symbol->string name)
|
|
(number->string val)))
|
|
(((? symbol? name) (? cell? cell))
|
|
(r:attribute cell elem name))
|
|
;; The value attribute is special and can be
|
|
;; used to setup a 2-way data binding.
|
|
(('value (? binding? binding))
|
|
(r:binding binding elem))
|
|
(('event (? string? event-name) (? procedure? proc))
|
|
(add-event-listener! elem event-name
|
|
(procedure->external proc)))))
|
|
attrs)
|
|
(add-children children))
|
|
(children (add-children children)))
|
|
elem))))
|
|
|
|
(define (r:dom input elem)
|
|
(define (activate)
|
|
(match (cell-strongest input)
|
|
(($ <ephemeral> exp)
|
|
(let ((new (sxml->dom exp)))
|
|
(replace-with! elem new)
|
|
(set! elem new)))
|
|
(_ (values))))
|
|
(make-propagator 'dom (list input) '() activate))
|
|
|
|
;; (define-primitive r:hsv->rgb hsv->rgb)
|
|
|
|
;;(define-constraint (r:components<->rgb r g b rgb)
|
|
;; (r:rgb-color r g b rgb)
|
|
;; (r:rgb-color-r rgb r)
|
|
;; (r:rgb-color-g rgb g)
|
|
;; (r:rgb-color-b rgb b))
|
|
|
|
(define (render exp)
|
|
(append-child! (document-body) (sxml->dom exp)))
|
|
|
|
(define-syntax-rule (with-cells (name ...) body . body*)
|
|
(let ((name (make-cell 'name #:merge merge-ephemerals)) ...) body . body*))
|
|
|
|
(define (note-component active)
|
|
(with-cells (enabled)
|
|
(define t:enabled (make-transient enabled))
|
|
(set-trans! t:enabled #f)
|
|
(define (on-click ev)
|
|
(set-trans! t:enabled (not (get-trans t:enabled))))
|
|
|
|
`(div (@ (class "note")
|
|
(event "click" ,on-click))
|
|
,(thru (active) (if active "I'm active!" "not active"))
|
|
,(thru (enabled) (if enabled "I'm enabled!" "not enabled")))))
|
|
|
|
(with-cells (first-name last-name full-name note-active)
|
|
(define name (make-reactive-id))
|
|
(define name-group (list first-name last-name))
|
|
|
|
(define note (note-component note-active))
|
|
|
|
(thru (first-name last-name -> full-name)
|
|
(string-append first-name " " last-name))
|
|
|
|
(render
|
|
`(div
|
|
(h1 "Propagators Playground")
|
|
(input (@ (type "text")
|
|
(value ,(binding (make-transient first-name name) #:default "vivi" #:group name-group))))
|
|
(input (@ (type "text")
|
|
(value ,(binding (make-transient last-name name) #:default "langdon" #:group name-group))))
|
|
(h2 ,full-name)
|
|
,note)))
|