diff --git a/propagators.scm b/propagators.scm index 734e8bb..686d920 100644 --- a/propagators.scm +++ b/propagators.scm @@ -274,22 +274,13 @@ (define (constraint-propagator name cells build) (compound-propagator name cells cells build)) - - (define-record-type - (%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 "#" port)) -(set-record-type-printer! 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 + (%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 + (($ 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 - (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 - (($ id cell default numeric? group) + (($ ($ 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 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 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 - (($ 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 - (($ 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 - (($ 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)))