1 files changed, 649 insertions, 0 deletions
diff --git a/chapter-7/propagators.scm b/chapter-7/propagators.scm
new file mode 100644
index 0000000..db27a2e
--- /dev/null
+++ b/chapter-7/propagators.scm
@@ -0,0 +1,649 @@
+(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 numbers) #:select (truncate))
+             (hoot ffi))
+
+(define-foreign make-element
+  "document" "makeElement"
+  (ref string) -> (ref extern))
+
+(define-foreign make-text-node
+  "document" "makeTextNode"
+  (ref string) -> (ref extern))
+
+(define-foreign get-element-by-id
+  "document" "getElementById"
+  (ref string) -> (ref null extern))
+
+(define-foreign first-child
+  "element" "firstChild"
+  (ref extern) -> (ref null extern))
+
+(define-foreign next-sibling
+  "element" "nextSibling"
+  (ref extern) -> (ref null extern))
+
+(define-foreign append-child!
+  "element" "appendChild"
+  (ref extern) (ref extern) -> (ref extern))
+
+(define-foreign attribute-ref
+  "element" "getAttribute"
+  (ref extern) (ref string) -> (ref string))
+
+(define-foreign set-attribute!
+  "element" "setAttribute"
+  (ref extern) (ref string) (ref string) -> none)
+
+(define-foreign property-ref
+  "element" "getProperty"
+  (ref extern) (ref string) -> (ref string))
+
+(define-foreign set-property!
+  "element" "setProperty"
+  (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 remove!
+  "element" "remove"
+  (ref extern) -> none)
+
+(define-foreign replace-with!
+  "element" "replaceWith"
+  (ref extern) (ref extern) -> none)
+
+(define-foreign document-body
+  "document" "getBody"
+  -> (ref null extern))
+
+(define-foreign timeout
+  "window" "setTimeout"
+  (ref extern) f64 -> i32)
+
+(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 (test-cell-content! cell)
+  (match cell
+    (($ <cell> _ neighbors content strongest equivalent? _
+               find-strongest handle-contradiction)
+     (let ((strongest* (find-strongest content)))
+       (cond
+        ((equivalent? strongest strongest*)
+         (set-cell-strongest! cell strongest*))
+        ((contradiction? strongest*)
+         (set-cell-strongest! cell strongest*)
+         (handle-contradiction cell))
+        (else
+         (set-cell-strongest! cell strongest*)
+         (for-each alert-propagator! neighbors)))))))
+
+(define (add-cell-content! cell new)
+  (let ((merge (cell-merge cell)))
+    (set-cell-content! cell (merge (cell-content cell) new))
+    (test-cell-content! cell)))
+
+(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 to-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)))
+          (to-build)
+          (set! built? #t))))
+    (define propagator (make-propagator name inputs outputs maybe-build))
+    propagator))
+
+(define (constraint-propagator name cells to-build)
+  (compound-propagator name cells cells to-build))
+
+(define-record-type <reactive-id>
+  (%make-reactive-id name clock)
+  reactive-id?
+  (name reactive-id-name)
+  (clock reactive-id-clock set-reactive-id-clock!))
+
+(define (print-reactive-id id port)
+  (display "#<reactive-id " port)
+  (display (reactive-id-name id) port)
+  (display ">" port))
+(set-record-type-printer! <reactive-id> print-reactive-id)
+
+(define (make-reactive-id name)
+  (%make-reactive-id name 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)
+  (let lp ((ephemerals ephemerals) (timestamps '()))
+    (match ephemerals
+      (() timestamps)
+      ((($ <ephemeral> _ timestamps*) . rest)
+       (let lp2 ((timestamps* timestamps*) (timestamps timestamps))
+         (match timestamps*
+           (() (lp rest timestamps))
+           (((and timestamp (key . time)) . rest)
+            (match (assq-ref timestamps key)
+              (#f (lp2 rest (cons timestamp timestamps)))
+              (time*
+               (if (= time time*)
+                   (lp2 rest timestamps)
+                   #f)))))))
+      ((_ . rest) (lp rest timestamps)))))
+
+(define (merge-ephemerals old new)
+  (cond
+   ((nothing? old) new)
+   ((nothing? new) old)
+   (else (if (ephemeral-fresher? new old) new 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* (primitive-reactive-propagator name proc)
+  (primitive-propagator name (ephemeral-wrap proc)))
+
+(define-syntax-rule (define-primitive-reactive-propagator name proc)
+  (define name (primitive-reactive-propagator 'name proc)))
+
+(define (r:property input elem property)
+  (let ((property (symbol->string property)))
+    (define (activate)
+      (match (cell-strongest input)
+        (($ <ephemeral> val)
+         (set-property! elem property (obj->string val)))
+        ;; Ignore unusable values.
+        (_ (values))))
+    (make-propagator 'property (list input) '() activate)))
+
+(define-record-type <binding>
+  (make-binding id cell default group)
+  binding?
+  (id binding-id)
+  (cell binding-cell)
+  (default binding-default)
+  (group binding-group))
+
+(define* (binding id cell #:key (default nothing) (group '()))
+  (make-binding id cell default 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> id cell default 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 (obj->string 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 (string->obj (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))
+                         (set-attribute! elem
+                                         (symbol->string name)
+                                         val))
+                        (((? symbol? name) (? number? val))
+                         (set-attribute! elem
+                                         (symbol->string name)
+                                         (number->string val)))
+                        (((? symbol? name) (? cell? cell))
+                         (r:property 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))))
+                    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-record-type <rgb-color>
+  (rgb-color r g b)
+  rgb-color?
+  (r rgb-color-r)
+  (g rgb-color-g)
+  (b rgb-color-b))
+
+(define-record-type <hsv-color>
+  (hsv-color h s v)
+  hsv-color?
+  (h hsv-color-h)
+  (s hsv-color-s)
+  (v hsv-color-v))
+
+(define (assert-real x)
+  (unless (real? x)
+    (error "expected real number" x)))
+
+(define (fmod x y)
+  (assert-real x)
+  (assert-real y)
+  (- x (* (truncate (/ x y)) y)))
+
+(define (rgb->hsv rgb)
+  (match rgb
+    (($ <rgb-color> r g b)
+     (let* ((cmax (max r g b))
+            (cmin (min r g b))
+            (delta (- cmax cmin)))
+       (hsv-color (cond
+                   ((= delta 0.0) 0.0)
+                   ((= cmax r)
+                    (let ((h (* 60.0 (fmod (/ (- g b) delta) 6.0))))
+                      (if (< h 0.0) (+ h 360.0) h)))
+                   ((= cmax g) (* 60.0 (+ (/ (- b r) delta) 2.0)))
+                   ((= cmax b) (* 60.0 (+ (/ (- r g) delta) 4.0))))
+                  (if (= cmax 0.0)
+                      0.0
+                      (/ delta cmax))
+                  cmax)))))
+
+(define (hsv->rgb hsv)
+  (match hsv
+    (($ <hsv-color> h s v)
+     (let* ((h' (/ h 60.0))
+            (c (* v s))
+            (x (* c (- 1.0 (abs (- (fmod h' 2.0) 1.0)))))
+            (m (- v c)))
+       (define-values (r' g' b')
+         (cond
+          ((<= 0.0 h 60.0) (values c x 0.0))
+          ((<= h 120.0) (values x c 0.0))
+          ((<= h 180.0) (values 0.0 c x))
+          ((<= h 240.0) (values 0.0 x c))
+          ((<= h 300.0) (values x 0.0 c))
+          ((<= h 360.0) (values c 0.0 x))))
+       (rgb-color (+ r' m) (+ g' m) (+ b' m))))))
+
+(define (uniform->byte x)
+  (inexact->exact (round (* x 255.0))))
+
+(define (rgb->int rgb)
+  (match rgb
+    (($ <rgb-color> r g b)
+     (+ (* (uniform->byte r) (ash 1 16))
+        (* (uniform->byte g) (ash 1 8))
+        (uniform->byte b)))))
+
+(define (rgb->hex-string rgb)
+  (list->string
+   (cons #\#
+         (let lp ((i 0) (n (rgb->int rgb)) (out '()))
+           (if (= i 6)
+               out
+               (lp (1+ i) (ash n -4)
+                   (cons (integer->char
+                          (let ((digit (logand n 15)))
+                            (+ (if (< digit 10)
+                                   (char->integer #\0)
+                                   (- (char->integer #\a) 10))
+                               digit)))
+                         out)))))))
+
+(define (rgb-hex->style hex)
+  (string-append "background-color: " hex ";"))
+
+(define-primitive-reactive-propagator r:rgb-color rgb-color)
+(define-primitive-reactive-propagator r:rgb-color-r rgb-color-r)
+(define-primitive-reactive-propagator r:rgb-color-g rgb-color-g)
+(define-primitive-reactive-propagator r:rgb-color-b rgb-color-b)
+(define-primitive-reactive-propagator r:hsv-color hsv-color)
+(define-primitive-reactive-propagator r:hsv-color-h hsv-color-h)
+(define-primitive-reactive-propagator r:hsv-color-s hsv-color-s)
+(define-primitive-reactive-propagator r:hsv-color-v hsv-color-v)
+(define-primitive-reactive-propagator r:rgb->hsv rgb->hsv)
+(define-primitive-reactive-propagator r:hsv->rgb hsv->rgb)
+(define-primitive-reactive-propagator r:rgb->hex-string rgb->hex-string)
+(define-primitive-reactive-propagator r:rgb-hex->style rgb-hex->style)
+
+(define (r:components<->rgb r g b rgb)
+  (define (build)
+    (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))
+  (constraint-propagator 'r:components<->rgb (list r g b rgb) build))
+
+(define (r:components<->hsv h s v hsv)
+  (define (build)
+    (r:hsv-color h s v hsv)
+    (r:hsv-color-h hsv h)
+    (r:hsv-color-s hsv s)
+    (r:hsv-color-v hsv v))
+  (constraint-propagator 'r:components<->hsv (list h s v hsv) build))
+
+(define (r:rgb<->hsv rgb hsv)
+  (define (build)
+    (r:rgb->hsv rgb hsv)
+    (r:hsv->rgb hsv rgb))
+  (constraint-propagator 'r:components<->hsv (list rgb hsv) build))
+
+(define (render exp)
+  (append-child! (document-body) (sxml->dom exp)))
+
+(define* (slider id name min max default #:optional (step "any"))
+  `(div (@ (class "slider"))
+        (label (@ (for ,id)) ,name)
+        (input (@ (id ,id) (type "range")
+                  (min ,min) (max ,max) (step ,step)
+                  (value ,default)))))
+
+(define (uslider id name default) ; [0,1] slider
+  (slider id name 0 1 default))
+
+(define-syntax-rule (with-cells (name ...) body . body*)
+  (let ((name (make-cell 'name #:merge merge-ephemerals)) ...) body . body*))
+
+(with-cells (r g b rgb h s v hsv hex style)
+  (define color (make-reactive-id 'color))
+  (define rgb-group (list r g b))
+  (define hsv-group (list h s v))
+  (r:components<->rgb r g b rgb)
+  (r:components<->hsv h s v hsv)
+  (r:rgb<->hsv rgb hsv)
+  (r:rgb->hex-string rgb hex)
+  (r:rgb-hex->style hex style)
+  (render
+   `(div
+     (h1 "Color Picker")
+     (div (@ (class "preview"))
+          (div (@ (class "color-block") (style ,style)))
+          (div (@ (class "hex")) ,hex))
+     (fieldset
+      (legend "RGB")
+      ,(uslider "red" "Red"
+                (binding color r #:default 1.0 #:group rgb-group))
+      ,(uslider "green" "Green"
+                (binding color g #:default 0.0 #:group rgb-group))
+      ,(uslider "blue" "Blue"
+                (binding color b #:default 1.0 #:group rgb-group)))
+     (fieldset
+      (legend "HSV")
+      ,(slider "hue" "Hue" 0 360 (binding color h #:group hsv-group))
+      ,(uslider "saturation" "Saturation" (binding color s #:group hsv-group))
+      ,(uslider "value" "Value" (binding color v #:group hsv-group))))))