dataflow.scm

;; https://github.com/clojure/clojure-contrib/blob/master/modules/dataflow/src/main/clojure/clojure/contrib/dataflow.clj

;; todo
;;   link dataflows
;;   no collection toplevel streams
;;   names that start with *
;;   toposort finds cycles
;;   syntax-extensions

(load "util.scm")

;; sets

(define set
  (case-lambda
    (() (make-eq-hashtable))
    (args (let ( (out (set)) )
            (map (lambda (x) (set.add! out x)) args)
            out))))

(define (set.copy s)
  (hashtable-copy s #t))

(define (set.print s)
  (display "#{ ")
  (hash-table-for-each
    s
    (lambda (k v)
      (display k)
      (display " ")))
  (display "}\n"))

(define (set.add! set obj)
  (hashtable-set! set obj #t))

(define (set.add set obj)
  (let ( (out (set.copy set)) )
    (set.add! out obj)
    out))

(define (set.remove! set obj)
  (hashtable-delete! set obj))

(define (set.remove set obj)
  (let ( (out (set.copy set)) )
    (set.remove! out obj)
    out))

(define (set.has? s k)
  (hashtable-contains? s k))

(define (set.union a b)
  (let ( (out (set.copy a)) )
    (hash-table-for-each b
      (lambda (k v)
        (unless (set.has? out k)
          (set.add! out k))))
    out))

(define (set.difference a b)
  (let ( (out (set)) )
    (hash-table-for-each a
      (lambda (k v)
        (unless (set.has? b k)
          (set.add! out k))))
    out))

(define (set.intersection a b)
  (let ( (out (set)) )
    (hash-table-for-each a
      (lambda (k v)
        (when (set.has? b k)
          (set.add! out k))))
    out))

(define (set.map fn s)
  (hash-table-map s
    (lambda (k v)
      (fn k))))

(define (set->list s)
  (vector->list (hashtable-keys s)))

(define (list->set l)
  (apply set l))

;; graphs stuff

(define (directed-graph nodes neighbors)
  (let ( (ht (make-eq-hashtable)) )
    (for-each (lambda (a b)
      (hashtable-set! ht a b)) nodes neighbors)
    ht))

(define (graph.reverse graph)
  (let ( (ht (make-eq-hashtable)) )
    (hash-table-for-each graph
      (lambda (k v)
        (unless (hashtable-contains? ht k)
          (hashtable-set! ht k '()))
        (map (lambda (dep)
          (hashtable-update! ht dep
            (lambda (val)
              (cons k val)) '())) v)))
    ht))

(define (graph.toposort graph)
  (let ( (visited (set)) (sorted '()) )
    (define (visit k)
      (unless (set.has? visited k)
        (map visit (hashtable-ref graph k '()))
        (set.add! visited k)
        (set! sorted (cons k sorted))))
    (hash-table-for-each graph
      (lambda (k v)
        (visit k)))
    sorted))

;; cell

(define make-cell
  (case-lambda
    ((name)
      (vector 'toplvl name 'invalid-value #f))
    ((name init)
      (vector 'toplvl name init #t))
    ((name deps fn)
      (vector 'normal name 'invalid-value #f deps fn))))

(getter cell.type    0)
(getter cell.name    1)
(getter cell.value   2)
(getter cell.changed 3)
(getter cell.deps    4)
(getter cell.fn      5)

(setter cell._value!   2)
(setter cell._changed! 3)
(setter cell._deps!    4)

(define (cell.value! c val)
  (cell._changed! c #t)
  (cell._value! c val))

(define (toplvl? cell)
  (eq? (cell.type cell) 'toplvl))

(define (normal? cell)
  (eq? (cell.type cell) 'normal))

(define cell.copy vector-copy)

(define (cell.recalc? c)
  (fold-right
    (lambda (a b) (or a b))
    #f
    (map cell.changed (flatten (cell.deps c)))))

(define (cell.calc! c)
  (let ( (val ((cell.fn c) (list->vector (cell.deps c)))) )
    (unless (eq? val (void))
      (cell.value! c val))))

;;

(define (make-cells-map cs)
  (let ( (out (make-eq-hashtable)) )
    (map (lambda (c)
            (hashtable-update! out (cell.name c)
              (lambda (l) (cons c l)) '())) cs)
    out))

(define (make-back-graph cs cell-map)
  (directed-graph
    cs
    (let ( (name->cells (lambda (name)
                          ;; todo  name not found error
                          (hashtable-ref cell-map name '()))) )
      (map (lambda (c)
              (if (toplvl? c)
                  '()
                  (apply append (map name->cells (cell.deps c)))))
        cs))))

(define (cell.resolve! c cells-map)
  (unless (toplvl? c)
    (cell._deps! c
          (map
            (lambda (name)
              ;; dependency not found error
              (hashtable-ref cells-map name '()))
            (cell.deps c)))
    c))

(define (cell.unresolve! c)
  (unless (toplvl? c)
    (cell._deps! c
      (map (lambda (cs) (cell.name (car cs))) (cell.deps c)))
    c))

;;

(define (make-dataflow cells)
  (let* ( (cmap       (make-cells-map cells))
          (back-graph (make-back-graph cells cmap))
          (fore-graph (graph.reverse back-graph))
          (topo       (graph.toposort fore-graph)) )
    (map (lambda (c) (cell.resolve! c cmap)) topo)
    (vector cmap topo)))

(define (init-dataflow) 0)

(getter dataflow.cells-map 0)
(getter dataflow.topo      1)

(define (dataflow.calc! df)
  (for-each
    (lambda (cell)
      (unless (toplvl? cell)
        (when (cell.recalc? cell)
          (cell.calc! cell))))
    (dataflow.topo df)))

(define (dataflow.reset! df)
  (map (lambda (c) (cell._changed! c #f)) (dataflow.topo df))
  (void))

(define (dataflow.add-cells! df cs)
  (map cell.unresolve! (dataflow.topo df))
  (make-dataflow (append cs (dataflow.topo df))))

(define (dataflow.remove-cells! df cs)
  (make-dataflow (set->list (set.difference (list->set cs) (list->set (dataflow.topo df))))))

;; todo
;;   dataflow.add cells
;;            reomve cells
;;            set values
;;     >>needs list to hmap

;; deep copy cmap
;; unresolve names
;; add cells
;; resolve cells
;; out copied ht

;; setting values by name solves the issue of reverences going invalid after copying and adding cells to original map

;; making dataflow mutable solves all these issues
;; unresolve cells
;; add cells
;; recreate topology

;; no toplvlcells invalidated
;; still no lookups


;;

(define (/fclock name time phase)
  (let ( (acc 0) (state 'low) (half (/ phase 2)) )
    (make-cell name (list time)
      (lambda (d)
        (let ( (time (car (aref d 0))) )
          (set! acc (+ acc (cell.value time)))
          (if (> acc half)
              (begin
                (set! acc 0)
                (case state ('low (set! state 'high) 'rising)
                            ('high (set! state 'low) 'falling)))
              state)))
      )))


;;

(define df
  (make-dataflow
    (list
      (make-cell 'name 'name-value)
      (make-cell 'mult 20)
      (make-cell 'mult 30)

      (make-cell 'two '(name mult)
        (lambda (d)
          (let ( (name (car (aref d 0))) (mults (aref d 1)) )
            (dnL "name" (cell.value name) "ms" (map cell.value mults)))))

      (make-cell 'two '(name)
        (lambda (d)
          (dnL d)
          15))

      (make-cell 'dt '(two)
        (lambda (d)
          (dnL "two" d)
          30))

      (make-cell 'three '(name mult)
        (lambda (vd)
          (let ( (name (aref vd 0)) (mult (aref vd 1)) )
            (if (cell.changed (car name))
                (cell.value (car name))
                0))))

      (/fclock 'timer 'name 0.5)
      )))

(define a1
  (make-dataflow
    (list
      (make-cell 'a)
      (make-cell 'b '(a)
        (lambda (d)
          (dnL d)))
      )))

(define cs1
  (list
    (make-cell 'c)
    (make-cell 'd '(a)
      (lambda (d)
        (dnL d)))
    ))

(define cs2
  (list
    (make-cell 'e)
    (make-cell 'f '(a b c d e) +)))