689 lines
22 KiB
Scheme
689 lines
22 KiB
Scheme
;;; 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 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-syntax-rule (define-constraint (name cells ...) body ...)
|
|
(define (name cells ...)
|
|
(constraint-propagator
|
|
'name
|
|
(list cells ...)
|
|
(lambda () body ...))))
|
|
|
|
(define-syntax pbind
|
|
(syntax-rules (->)
|
|
((pbind (inputs ... -> output) body ...)
|
|
(begin
|
|
((primitive-reactive-propagator
|
|
'anonymous-propa
|
|
(lambda (inputs ...) body ...))
|
|
inputs ... output)
|
|
output))
|
|
((pbind (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 id cell default numeric? group)
|
|
binding?
|
|
(id binding-id)
|
|
(cell binding-cell)
|
|
(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 (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 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))))
|
|
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-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 (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 name (make-reactive-id 'name))
|
|
(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))))))))
|
|
|
|
(pbind (first-name last-name -> full-name)
|
|
(string-append first-name " " last-name))
|
|
|
|
(render
|
|
`(div
|
|
(h1 "Color Picker")
|
|
(input (@ (type "text")
|
|
(value ,(binding name first-name #:default "vivi" #:group name-group))))
|
|
(input (@ (type "text")
|
|
(value ,(binding name last-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))))))
|