hoot-propa/propagators.scm

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