vv/hoot-propa
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial experiments with 'transients' i probably will abandon

Browse source
This commit is contained in:
Vivianne 2024-07-29 20:20:19 -04:00
parent 8277922bd9
commit 34148672ec
1 changed files with 60 additions and 171 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

231
propagators.scm
View file

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