guile-scene/modules/reactive.scm

(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?
            !
            make-deriv
            deriv?
            ~
            if~
            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 (not (weak-ref-null? item))
             (proc item)
             (set! num-tombstones (1+ num-tombstones)))))
     (weak-list-items list)))

  (when (> num-tombstones (/ (weak-list-count list) 2))
    (format #t "Reaping! ~s / ~s\n" num-tombstones (weak-list-count list))
    (set-weak-list-items!
     list
     (filter (lambda (item) (not (weak-ref-null? (weak-ref-deref item)))) (weak-list-items list)))
    (set-weak-list-count! list (length (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)
     (let ((elem (weak-ref-deref wref)))
       (and (not (weak-ref-null? elem))
            (eq? x elem))))
   (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)
     (when (not (eq? (cell-value cell) new-value))
       (set-cell-value! cell new-value)
       (trigger subscribers 'set)))
    ((($ <deriv> cell effect proc))
     (! cell))))

(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 (make-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 (if~ test consequent alternate)
  (let ((test-proc (lambda () test))
        (consequent-proc (lambda () consequent))
        (alternate-proc (lambda () alternate))
        (last-res-type 'none)
        (current-value #f))
    (~ (let* ((result (test-proc))
             (value (cond
                     ((and result
                           (not (eq? last-res-type #t)))
                      (set! last-res-type #t)
                      (consequent-proc))
                     ((and (not result)
                           (not (eq? last-res-type #f)))
                      (set! last-res-type #f)
                      (alternate-proc))
                     (else current-value))))
         (set! current-value value)
         value))))

(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 a (make-cell 4))
;; (define b (make-cell 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")