path: root/chapter-7/propagators.scm

(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))))))