diff options
Diffstat (limited to 'chapter-7/propagators.scm')
| -rw-r--r-- | chapter-7/propagators.scm | 659 |
1 files changed, 659 insertions, 0 deletions
diff --git a/chapter-7/propagators.scm b/chapter-7/propagators.scm new file mode 100644 index 0000000..c3d0cc4 --- /dev/null +++ b/chapter-7/propagators.scm @@ -0,0 +1,659 @@ +;;; Copyright © 2024 David Thompson <dthompson2@worcester.edu> +;;; +;;; 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 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) + (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* (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: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 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)) + (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)))) + 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:rgb<->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)))))) |