447 lines
13 KiB
Scheme
447 lines
13 KiB
Scheme
(define-module (reactive)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (srfi srfi-9 gnu)
|
|
#:use-module (hoot weak-refs)
|
|
#:use-module (ice-9 match)
|
|
#:export (make-cell
|
|
cell?
|
|
!
|
|
define-cell
|
|
make-deriv
|
|
deriv?
|
|
~
|
|
define~
|
|
make-cell-list
|
|
cell-list?
|
|
list->cell-list
|
|
set-cell-list-cells!
|
|
cell-list-ref
|
|
cell-list-append!
|
|
cell-list-set!
|
|
cell-list-append!
|
|
cell-list-append-cells!
|
|
cell-list-insert!
|
|
cell-list-insert-cell!
|
|
cell-list-delete!
|
|
cell-list-for-each
|
|
cell-list-map
|
|
cell-list->list
|
|
cell-list-length
|
|
make-deriv-list
|
|
deriv-list?
|
|
~map
|
|
deriv-list-ref
|
|
deriv-list-length
|
|
deriv-list-for-each
|
|
deriv-list-map
|
|
deriv-list->list))
|
|
|
|
(define-record-type <weak-list>
|
|
(_make-weak-list items count)
|
|
weak-list?
|
|
(items weak-list-items set-weak-list-items!)
|
|
(count weak-list-count set-weak-list-count!))
|
|
|
|
(define* (make-weak-list #:optional (items '()))
|
|
(_make-weak-list (map make-weak-ref items) (length items)))
|
|
|
|
(define (weak-list-prepend! list item)
|
|
(set-weak-list-items! list (cons (make-weak-ref item) (weak-list-items list)))
|
|
(set-weak-list-count! list (1+ (weak-list-count list))))
|
|
|
|
(define (weak-list-iter proc list iter-proc)
|
|
(define num-tombstones 0)
|
|
(define result
|
|
(iter-proc
|
|
(lambda (wref)
|
|
(let ((item (weak-ref-deref wref)))
|
|
(if item
|
|
(proc item)
|
|
(set! num-tombstones (1+ num-tombstones)))))
|
|
(weak-list-items list)))
|
|
|
|
(when (> num-tombstones (/ (weak-list-count list) 2))
|
|
(set-weak-list-items!
|
|
list
|
|
(filter weak-ref-deref (weak-list-items list))))
|
|
result)
|
|
|
|
(define (weak-list-for-each proc list)
|
|
(weak-list-iter proc list for-each))
|
|
|
|
(define (weak-list-map proc list)
|
|
(weak-list-iter proc list map))
|
|
|
|
;; no rnrs lists, or srfi-1 in hoot, this accomplishes that for us
|
|
(define (memp pred list)
|
|
(and (pair? list)
|
|
(if (pred (car list))
|
|
list
|
|
(memp pred (cdr list)))))
|
|
|
|
(define (weak-list-memq x list)
|
|
(memp
|
|
(lambda (wref) (eq? x (weak-ref-deref wref)))
|
|
(weak-list-items list)))
|
|
|
|
(define current-subscriber (make-parameter #f))
|
|
|
|
(define (trigger subscribers change-type)
|
|
(weak-list-for-each
|
|
(lambda (sub) (sub change-type))
|
|
subscribers))
|
|
|
|
(define (track! subscribers)
|
|
(define sub (current-subscriber))
|
|
(when (and sub
|
|
(not (weak-list-memq sub subscribers)))
|
|
(weak-list-prepend! subscribers sub)))
|
|
|
|
(define-record-type <cell>
|
|
(_make-cell value subscribers)
|
|
cell?
|
|
(value cell-value set-cell-value!)
|
|
(subscribers cell-subscribers))
|
|
|
|
(set-record-type-printer! <cell> (lambda (c op) (format op "#<cell ~s>" (cell-value c))))
|
|
|
|
(define (make-cell value)
|
|
(_make-cell value (make-weak-list)))
|
|
|
|
(define !
|
|
(match-lambda*
|
|
(((and cell ($ <cell> value subscribers)))
|
|
(track! subscribers)
|
|
value)
|
|
(((and cell ($ <cell> value subscribers)) new-value)
|
|
(set-cell-value! cell new-value)
|
|
(trigger subscribers 'set))
|
|
((($ <deriv> cell effect proc))
|
|
(! cell))))
|
|
|
|
(define-syntax-rule (define-cell name value)
|
|
(define name (make-cell value)))
|
|
|
|
(define-record-type <deriv>
|
|
(_make-deriv cell effect proc)
|
|
deriv?
|
|
(cell deriv-cell)
|
|
(effect deriv-effect)
|
|
(proc deriv-proc))
|
|
|
|
(set-record-type-printer! <deriv> (lambda (d op) (format op "#<deriv ~s>" (deriv-proc d))))
|
|
|
|
(define (make-deriv proc)
|
|
(define-cell cell #f)
|
|
|
|
(define deriv
|
|
(_make-deriv cell effect proc))
|
|
|
|
(define (effect change-type)
|
|
(format #t "effect (type ~a) running for ~s\n" change-type deriv)
|
|
(! cell
|
|
(parameterize ((current-subscriber effect))
|
|
(proc))))
|
|
|
|
(effect 'set)
|
|
deriv)
|
|
|
|
(define (deriv-value deriv)
|
|
(cell-value (deriv-cell deriv)))
|
|
|
|
;; shorthand
|
|
(define-syntax-rule (~ body ...)
|
|
(make-deriv (lambda () body ...)))
|
|
|
|
(define-syntax-rule (define~ name body ...)
|
|
(define name (~ body ...)))
|
|
|
|
(define-record-type <cell-list>
|
|
(_make-cell-list cells iteration-subs length-subs)
|
|
cell-list?
|
|
(cells cell-list-cells _set-cell-list-cells!)
|
|
(iteration-subs cell-list-iteration-subs set-cell-list-iteration-subs!)
|
|
(length-subs cell-list-length-subs set-cell-list-length-subs!))
|
|
|
|
(set-record-type-printer!
|
|
<cell-list>
|
|
(lambda (cl op)
|
|
(format op "#<cell-list: ~s>" (map cell-value (cell-list-cells cl)))))
|
|
|
|
;; List cell (shallow for now)
|
|
(define (make-cell-list cells)
|
|
(_make-cell-list cells (make-weak-list) (make-weak-list)))
|
|
|
|
(define (list->cell-list items)
|
|
(make-cell-list (map make-cell items)))
|
|
|
|
(define (set-cell-list-cells! cell-list cells)
|
|
(define old-len (length (cell-list-cells cell-list)))
|
|
(_set-cell-list-cells! cell-list cells)
|
|
(trigger (cell-list-iteration-subs cell-list) 'set)
|
|
(when (not (eq? old-len (length cells)))
|
|
(trigger (cell-list-length-subs cell-list) 'resize)))
|
|
|
|
(define (cell-list-ref cell-list index)
|
|
;; returns the cell, not its value
|
|
(list-ref (cell-list-cells cell-list) index))
|
|
|
|
(define (cell-list-set! cell-list index value)
|
|
(! (list-ref (cell-list-cells cell-list) index) value))
|
|
|
|
(define (cell-list-append! cell-list tail)
|
|
(cell-list-append-cells! cell-list (map make-cell tail)))
|
|
|
|
(define (cell-list-append-cells! cell-list tail-cells)
|
|
(_set-cell-list-cells! cell-list (append! (cell-list-cells cell-list) tail-cells))
|
|
(trigger (cell-list-iteration-subs cell-list) 'append)
|
|
(trigger (cell-list-length-subs cell-list) 'resize))
|
|
|
|
(define (cell-list-insert! cell-list index value)
|
|
(cell-list-insert-cell! cell-list index (make-cell value)))
|
|
|
|
(define (cell-list-insert-cell! cell-list index cell)
|
|
(define cells (cell-list-cells cell-list))
|
|
(define list-length (length cells))
|
|
|
|
(if (= index list-length)
|
|
(cell-list-append-cells! cell-list '(cell))
|
|
(begin
|
|
(unless (and (>= index 0)
|
|
(< index list-length))
|
|
(error "list index out of range"))
|
|
|
|
(let ((before (list-head cells index))
|
|
(after (list-tail cells index)))
|
|
|
|
(_set-cell-list-cells! cell-list (append before (cons cell after)))
|
|
|
|
(trigger (cell-list-iteration-subs cell-list) (cons 'insert index))
|
|
(trigger (cell-list-length-subs cell-list) 'resize)))))
|
|
|
|
(define (cell-list-delete! cell-list index)
|
|
(define cells (cell-list-cells cell-list))
|
|
|
|
(unless (and (>= index 0)
|
|
(< index (length cells)))
|
|
(error "list index out of range" index))
|
|
|
|
(define before (list-head cells index))
|
|
(define after (list-tail cells (1+ index)))
|
|
|
|
(_set-cell-list-cells! cell-list (append before after))
|
|
|
|
(trigger (cell-list-iteration-subs cell-list) (cons 'delete index))
|
|
(trigger (cell-list-length-subs cell-list) 'resize))
|
|
|
|
|
|
(define (cell-list-iter proc cell-list iter)
|
|
(track! (cell-list-iteration-subs cell-list))
|
|
(iter (lambda (cell) (proc cell)) (cell-list-cells cell-list)))
|
|
|
|
(define (cell-list-for-each proc cell-list)
|
|
(cell-list-iter proc cell-list for-each))
|
|
|
|
(define (cell-list-map proc cell-list)
|
|
(cell-list-iter proc cell-list map))
|
|
|
|
(define (cell-list->list cell-list)
|
|
(cell-list-map (lambda (c) (! c)) cell-list))
|
|
|
|
(define (cell-list-length cell-list)
|
|
(track! (cell-list-length-subs cell-list))
|
|
(length (cell-list-cells cell-list)))
|
|
|
|
(define-record-type <deriv-list>
|
|
(_make-deriv-list derivs proc effect iteration-subs length-subs)
|
|
deriv-list?
|
|
(derivs deriv-list-derivs set-deriv-list-derivs!)
|
|
(proc deriv-list-proc)
|
|
(effect deriv-list-effect)
|
|
(iteration-subs deriv-list-iteration-subs set-deriv-list-iteration-subs!)
|
|
(length-subs deriv-list-length-subs set-deriv-list-length-subs!))
|
|
|
|
(set-record-type-printer!
|
|
<deriv-list>
|
|
(lambda (dl op)
|
|
(format op "#<deriv-list ~s => ~s>" (deriv-list-proc dl) (map deriv-value (deriv-list-derivs dl)))))
|
|
|
|
(define (make-deriv-list proc source)
|
|
(define deriv-list
|
|
(_make-deriv-list
|
|
'()
|
|
proc
|
|
iteration-effect
|
|
(make-weak-list)
|
|
(make-weak-list)))
|
|
|
|
(define map-proc
|
|
(match source
|
|
((? deriv-list?) deriv-list-map)
|
|
((? cell-list?) cell-list-map)))
|
|
|
|
(define (source-items)
|
|
(match source
|
|
((? deriv-list?) (deriv-list-derivs source))
|
|
((? cell-list?) (cell-list-cells source))))
|
|
|
|
(define (source-iters)
|
|
(match source
|
|
((? deriv-list?) (deriv-list-iteration-subs source))
|
|
((? cell-list?) (cell-list-iteration-subs source))))
|
|
|
|
(define (iteration-effect change-type)
|
|
(define initial-length (length (deriv-list-derivs deriv-list)))
|
|
(define derivs (deriv-list-derivs deriv-list))
|
|
(format #t "iteration effect (type ~a) running for ~a\n" change-type deriv-list)
|
|
(match change-type
|
|
('append
|
|
(let* ((cur-length (length derivs))
|
|
(source-new-cdr (list-tail (source-items) cur-length)))
|
|
(set-deriv-list-derivs!
|
|
deriv-list
|
|
(append! derivs (map (lambda (i) (~ (proc i))) source-new-cdr)))))
|
|
(('insert . index)
|
|
(let* ((source-item (list-ref (source-items) index))
|
|
(new-deriv (~ (proc source-item)))
|
|
(before (list-head derivs index))
|
|
(after (list-tail derivs index)))
|
|
(set-deriv-list-derivs!
|
|
deriv-list
|
|
(append before (cons new-deriv after)))))
|
|
(('delete . index)
|
|
(let* ((before (list-head derivs index))
|
|
(after (list-tail derivs (1+ index))))
|
|
(set-deriv-list-derivs!
|
|
deriv-list
|
|
(append before after)))
|
|
#f)
|
|
('resize
|
|
;; I don't think it's possible for this to be triggered by a resize as resize is only fired by length subscribers
|
|
(error "should not be possible for deriv-list to be triggered by a resize."))
|
|
(else
|
|
(set-deriv-list-derivs!
|
|
deriv-list
|
|
(parameterize ((current-subscriber iteration-effect))
|
|
(map-proc
|
|
(lambda (i) (~ (proc i)))
|
|
source)))))
|
|
|
|
(trigger (deriv-list-iteration-subs deriv-list) change-type)
|
|
(when (not (eq? initial-length
|
|
(length (deriv-list-derivs deriv-list))))
|
|
(trigger (deriv-list-length-subs deriv-list) 'resize)))
|
|
|
|
(track! (deriv-list-iteration-subs deriv-list))
|
|
(iteration-effect 'set)
|
|
deriv-list)
|
|
|
|
(define ~map make-deriv-list)
|
|
|
|
(define (deriv-list-ref deriv-list index)
|
|
(list-ref (deriv-list-derivs deriv-list) index))
|
|
|
|
(define (deriv-list-length deriv-list)
|
|
(track! (deriv-list-length-subs deriv-list))
|
|
(length (deriv-list-derivs deriv-list)))
|
|
|
|
(define (deriv-list-iter proc deriv-list iter)
|
|
(track! (deriv-list-iteration-subs deriv-list))
|
|
(iter proc (deriv-list-derivs deriv-list)))
|
|
|
|
(define (deriv-list-for-each proc deriv-list)
|
|
(deriv-list-iter proc deriv-list for-each))
|
|
|
|
(define (deriv-list-map proc deriv-list)
|
|
(deriv-list-iter proc deriv-list map))
|
|
|
|
(define (deriv-list->list deriv-list)
|
|
(deriv-list-map (lambda (d) (! d)) deriv-list))
|
|
|
|
;; (test-begin "scene")
|
|
;;
|
|
;; (define-cell a 4)
|
|
;; (define-cell b 5)
|
|
;; (define~ c (+ (! a) (! b)))
|
|
;;
|
|
;; (format #t "c computed as 9\n")
|
|
;;
|
|
;; (test-equal 9 (! c))
|
|
;;
|
|
;; (! a 6)
|
|
;;
|
|
;; (format #t "c computed as 11\n")
|
|
;;
|
|
;; (test-equal 11 (! c))
|
|
;;
|
|
;; (define items (list->cell-list '(4 5 6)))
|
|
;;
|
|
;; (define second-item (cell-list-ref items 1))
|
|
;;
|
|
;; (test-equal 5 (! second-item))
|
|
;;
|
|
;; (format #t "creating 'adding-one' deriv-list\n")
|
|
;;
|
|
;; (define adding-one (~map (lambda (x) (+ (! x) 1)) items))
|
|
;;
|
|
;; (test-equal "first item in adding one should be one more than the original cell-list" 5 (! (deriv-list-ref adding-one 0)))
|
|
;;
|
|
;; (format #t "setting item index 1 to 456\n")
|
|
;;
|
|
;; (cell-list-set! items 1 456)
|
|
;; (test-equal 456 (! second-item))
|
|
;; (test-equal "second item in adding one should be one more than the just set value" 457 (! (deriv-list-ref adding-one 1)))
|
|
;;
|
|
;; (format #t "appending 3 items to the list\n")
|
|
;;
|
|
;; (cell-list-append! items '(10 11 12))
|
|
;;
|
|
;; (format #t "setting item index 1 to 42\n")
|
|
;; (cell-list-set! items 1 42)
|
|
;;
|
|
;; (test-equal 42 (! second-item))
|
|
;; (test-equal "second item in adding one should be one more than the just set value" 43 (! (deriv-list-ref adding-one 1)))
|
|
;;
|
|
;; (define (render element)
|
|
;; (match element
|
|
;; ((or (? cell?) (? deriv?))
|
|
;; (render (! element)))
|
|
;; ((? list?)
|
|
;; (map render element))
|
|
;; ((? cell-list?)
|
|
;; (cell-list-map render element))
|
|
;; ((? deriv-list?)
|
|
;; (deriv-list-map render element))
|
|
;; (else element)))
|
|
;;
|
|
;; (format #t "making body\n")
|
|
;;
|
|
;; (define body
|
|
;; `(body
|
|
;; ;; Ordering issue: sometimes the inner b calculation is triggered first which causes the body to be recalculated twice
|
|
;; ;; and the first recalculation to be thrown away. This is difficult to avoid because we don't have ordering with hash tables
|
|
;; (h1 ,a " minus " ,b " is:")
|
|
;; (p "the number: " ,(~ (- (! a) (! b))))
|
|
;; (p "there are " ,(~ (cell-list-length items)) " items.")
|
|
;; (ul
|
|
;; ,(~map (lambda (x) `(li ,x)) items))))
|
|
;;
|
|
;; (define~ renderer (let ((value (render body)))
|
|
;; (format #t "\n~a\n\n" value)
|
|
;; value))
|
|
;;
|
|
;; (! b 26)
|
|
;;
|
|
;; (cell-list-set! items 3 888)
|
|
;;
|
|
;; (cell-list-delete! items 3)
|
|
;;
|
|
;; (cell-list-insert! items 2 420)
|
|
;;
|
|
;; (cell-list-insert! items 2 69)
|
|
;;
|
|
;; (test-equal '(4 42 69 420 6 11 12) (cell-list->list items))
|
|
;; (test-equal '(5 43 70 421 7 12 13) (deriv-list->list adding-one))
|
|
;;
|
|
;; (test-end "scene")
|