Initial experiments with 'transients' i probably will abandon

propagators.scm

@@ -274,22 +274,13 @@
 (define (constraint-propagator name cells build)
   (compound-propagator name cells cells build))
 
-
-
 (define-record-type <reactive-id>
-  (%make-reactive-id name clock)
+  (%make-reactive-id 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 (make-reactive-id)
+  (%make-reactive-id 0))
 
 (define (reactive-id-tick! id)
   (let ((t (1+ (reactive-id-clock id))))
@@ -367,10 +358,28 @@
        (#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-reactive-propagator name proc)
+(define-syntax-rule (define-primitive name proc)
   (define name (primitive-reactive-propagator 'name proc)))
 
 (define-syntax-rule (define-constraint (name cells ...) body ...)
@@ -380,16 +389,16 @@
      (list cells ...)
      (lambda () body ...))))
 
-(define-syntax pbind
+(define-syntax thru
   (syntax-rules (->)
-    ((pbind (inputs ... -> output) body ...)
+    ((thru (inputs ... -> output) body ...)
      (begin
        ((primitive-reactive-propagator
          'anonymous-propa
          (lambda (inputs ...) body ...))
         inputs ... output)
        output))
-    ((pbind (inputs ...) body ...)
+    ((thru (inputs ...) body ...)
      (let ((output (make-cell 'anonymous-cell)))
        ((primitive-reactive-propagator
          'anonymous-propa
@@ -408,16 +417,15 @@
     (make-propagator 'r:attribute (list input) '() activate)))
 
 (define-record-type <binding>
-  (make-binding id cell default numeric? group)
+  (make-binding trans default numeric? group)
   binding?
-  (id binding-id)
-  (cell binding-cell)
+  (trans binding-trans)
   (default binding-default)
   (numeric? binding-numeric?)
   (group binding-group))
 
-(define* (binding id cell #:key (default nothing) (numeric? #f) (group '()))
-  (make-binding id cell default numeric? group))
+(define* (binding trans #:key (default nothing) (numeric? #f) (group '()))
+  (make-binding trans default numeric? group))
 
 (define (obj->string obj)
   (if (string? obj)
@@ -431,10 +439,10 @@
 
 (define* (r:binding binding elem)
   (match binding
-    (($ <binding> id cell default numeric? group)
+    (($ <binding> ($ <transient> cell id) default numeric? group)
      (define (update new)
        (unless (nothing? new)
-         (let ((timestamp (reactive-id-tick! id)))
+         (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)
@@ -504,7 +512,10 @@
                         ;; The value attribute is special and can be
                         ;; used to setup a 2-way data binding.
                         (('value (? binding? binding))
-                         (r:binding binding elem))))
+                         (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)))
@@ -520,169 +531,47 @@
       (_ (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-primitive r:hsv->rgb hsv->rgb)
 
-(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-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-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-constraint (r:components<->hsv h s v hsv)
-  (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))
-
-(define-constraint (r:rgb<->hsv rgb hsv)
-  (r:rgb->hsv rgb hsv)
-  (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* (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 first-name last-name full-name)
-  (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)
+(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))))
 
-  (define name (make-reactive-id 'name))
+    `(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 hex
-    (pbind (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 note (note-component note-active))
 
-  (pbind (first-name last-name -> full-name)
+  (thru (first-name last-name -> full-name)
     (string-append first-name " " last-name))
 
   (render
    `(div
-     (h1 "Color Picker")
+     (h1 "Propagators Playground")
      (input (@ (type "text")
-               (value ,(binding name first-name #:default "vivi" #:group name-group))))
+               (value ,(binding (make-transient first-name name) #:default "vivi" #:group name-group))))
      (input (@ (type "text")
-               (value ,(binding name last-name #:default "langdon" #:group name-group))))
+               (value ,(binding (make-transient last-name name) #:default "langdon" #:group name-group))))
      (h2 ,full-name)
-     (div (@ (class "preview"))
-          (div (@ (class "color-block")
-                  (style ,(pbind (hex) (string-append "background-color: " hex ";")))))
-          (div (@ (class "hex")) ,hex))
-     (fieldset
-      (legend "RGB")
-      ,(uslider "red" "Red"
-                (binding color r #:default 1.0 #:numeric? #t #:group rgb-group))
-      ,(uslider "green" "Green"
-                (binding color g #:default 0.0 #:numeric? #t #:group rgb-group))
-      ,(uslider "blue" "Blue"
-                (binding color b #:default 1.0 #:numeric? #t #:group rgb-group)))
-     (fieldset
-      (legend "HSV")
-      ,(slider "hue" "Hue" 0 360 (binding color h #:numeric? #t #:group hsv-group))
-      ,(uslider "saturation" "Saturation" (binding color s #:numeric? #t #:group hsv-group))
-      ,(uslider "value" "Value" (binding color v #:numeric? #t #:group hsv-group))))))
+     ,note)))