3 files changed, 590 insertions, 1 deletions
diff --git a/src/clojure/contrib/dataflow.clj b/src/clojure/contrib/dataflow.clj
new file mode 100644
index 00000000..88b1082a
--- /dev/null
+++ b/src/clojure/contrib/dataflow.clj
@@ -0,0 +1,499 @@
+;;  Copyright (c) Jeffrey Straszheim. All rights reserved.  The use and
+;;  distribution terms for this software are covered by the Eclipse Public
+;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
+;;  be found in the file epl-v10.html at the root of this distribution.  By
+;;  using this software in any fashion, you are agreeing to be bound by the
+;;  terms of this license.  You must not remove this notice, or any other,
+;;  from this software.
+;;
+;;  dataflow.clj
+;;
+;;  A Library to Support a Dataflow Model of State
+;;
+;;  straszheimjeffrey (gmail)
+;;  Created 10 March 2009
+
+
+(ns clojure.contrib.dataflow
+  (:use [clojure.set :only (union intersection difference)])
+  (:use [clojure.contrib.graph :only (directed-graph
+                                      reverse-graph
+                                      dependency-list
+                                      get-neighbors)])
+  (:use [clojure.contrib.walk :only (postwalk)])
+  (:use [clojure.contrib.except :only (throwf)]))
+
+
+;;; Chief Data Structures
+
+
+;; Source Cell
+
+; The data of a source cell is directly set by a calling function.  It
+; never depends on other cells.
+
+(defstruct source-cell
+  :name             ; The name, a symbol
+  :value            ; Its value, a Ref
+  :cell-type)       ; Should be ::source-cell
+
+;; Cell
+
+; A standard cell that computes its value from other cells.
+
+(defstruct standard-cell
+  :name            ; The name, a symbol
+  :value           ; Its value, a Ref
+  :dependents      ; The names of cells on which this depends, a collection
+  :fun             ; A closure that computes the value, given an environment
+  :display         ; The original expression for display
+  :cell-type)      ; Should be ::cell
+
+(derive ::cell ::dependent-cell) ; A cell that has a dependents field
+
+;; Validator
+
+; A cell that has no value, but can throw an exception when run
+
+(defstruct validator-cell
+  :name            ; Always ::validator
+  :dependents      ; The names of cells on which this depends, a collection
+  :fun             ; A clojure that can throw an exception
+  :display         ; The original exprssion for display
+  :cell-type)      ; Should be ::validator-cell
+
+(derive ::validator-cell ::dependent-cell)
+
+
+;; A sentinal value
+
+(def *empty-value* (java.lang.Object.))
+
+
+;; Dataflow
+
+; A collection of cells and dependency information
+
+(defstruct dataflow
+  :cells          ; A set of all cells
+  :cells-map      ; A map of cell names (symbols) to collections of cells
+  :fore-graph     ; The inverse of the dependency graph, nodes are cells
+  :topological)   ; A vector of sets of independent nodes -- orders the computation
+
+
+;;; Environment Access
+
+(defn get-cells
+  "Get all the cells named by name"
+  [df name]
+  ((:cells-map @df) name))
+
+(defn get-cell
+  "Get the single cell named by name"
+  [df name]
+  (let [cells (get-cells df name)]
+    (cond
+     (= (count cells) 1) (first cells)
+     (> (count cells) 1) (throwf Exception "Cell %s has multiple instances" name)
+     :otherwise (throwf Exception "Cell %s is undefined" name))))
+
+(defn get-source-cells
+  "Returns a collection of source cells from the dataflow"
+  [df]
+  (for [cell (:cells @df)
+        :when (isa? (:cell-type cell) ::source-cell)]
+    cell))
+
+(defn get-value
+  "Gets a value from the df matching the passed symbol.
+   Signals an error if the name is not present, or if it not a single
+   value."  
+  [df name]
+  (let [cell (get-cell df name)
+        result @(:value cell)]
+    (do (when (= *empty-value* result)
+          (throwf Exception "Cell named %s empty" name))
+        result)))
+
+(defn get-values
+  "Gets a collection of values from the df by name"
+  [df name]
+  (let [cells (get-cells df name)
+        results (map #(-> % :value deref) cells)]
+    (do
+      (when (some #(= % *empty-value*) results)
+        (throwf Exception "At least one empty cell named %s found" name))
+      results)))
+
+(defn get-old-value
+  "Looks up an old value"
+  [df env name]
+  (if (contains? env name)
+    (env name)
+    (get-value df name)))
+
+(defn get-value-from-cell
+  "Given a cell, get its value"
+  [cell]
+  (-> cell :value deref))
+
+;;; Build Dataflow Structure
+
+(defn- build-cells-map
+  "Given a collection of cells, build a name->cells-collection map
+   from it."
+  [cs]
+  (let [step (fn [m c]
+               (let [n (:name c)
+                     o (get m n #{})
+                     s (conj o c)]
+                 (assoc m n s)))]
+    (reduce step {} cs)))
+
+(defn- build-back-graph
+  "Builds the backward dependency graph from the cells map.  Each
+   node of the graph is a cell."
+  [cells cells-map]
+  (let [step (fn [n]
+               (apply union (for [dep-name (:dependents n)]
+                              (cells-map dep-name))))
+        neighbors (zipmap cells (map step cells))]
+    (struct-map directed-graph
+        :nodes cells
+        :neighbors neighbors)))
+
+(defn- build-dataflow*
+  "Builds the dataflow structure"
+  [cs]
+  (let [cells (set cs)
+        cells-map (build-cells-map cs)
+        back-graph (build-back-graph cells cells-map)
+        fore-graph (reverse-graph back-graph)]
+    (struct-map dataflow
+      :cells cells
+      :cells-map cells-map
+      :fore-graph fore-graph
+      :topological (dependency-list back-graph))))
+
+(def initialize)
+
+(defn build-dataflow
+  "Given a collection of cells, build and return a dataflow object"
+  [cs]
+  (dosync
+   (let [df (ref (build-dataflow* cs))]
+     (initialize df)
+     df)))
+
+
+;;; Displaying a dataflow
+
+(defn print-dataflow
+  "Prints a dataflow, one cell per line"
+  [df]
+  (println)
+  (let [f (fn [cell] (-> cell :name str))]
+    (doseq [cell (sort-by f (:cells @df))]
+      (prn cell))))
+
+
+;;; Modifying a Dataflow
+
+(defn add-cells
+  "Given a collection of cells, add them to the dataflow."
+  [df cells]
+  (dosync
+   (let [new-cells (union (set cells) (:cells @df))]
+     (ref-set df (build-dataflow* new-cells))
+     (initialize df))))
+
+(defn remove-cells
+  "Given a collection of cells, remove them from the dataflow."
+  [df cells]
+  (dosync
+   (let [new-cells (difference (:cells @df) (set cells))]
+     (ref-set df (build-dataflow* new-cells))
+     (initialize df))))
+
+
+;;; Cell building
+
+(def *meta* {:type ::dataflow-cell})
+
+(defn build-source-cell
+  "Builds a source cell"
+  [name init]
+  (with-meta (struct source-cell name (ref init) ::source-cell)
+             *meta*))
+
+(defn- is-col-var?
+  [symb]
+  (let [name (name symb)]
+    (and (= \? (first name))
+         (= \* (second name)))))
+
+(defn- is-old-var?
+  [symb]
+  (let [name (name symb)]
+    (and (= \? (first name))
+         (= \- (second name)))))
+
+(defn- is-var?
+  [symb]
+  (let [name (name symb)]
+    (and (= \? (first name))
+         (-> symb is-col-var? not)
+         (-> symb is-old-var? not))))
+
+(defn- cell-name
+  [symb]
+  `(quote ~(cond (is-var? symb) (-> symb name (.substring 1) symbol)
+                 (or (is-col-var? symb)
+                     (is-old-var? symb)) (-> symb name (.substring 2) symbol))))
+
+(defn- replace-symbol
+  "Walk the from replacing the ?X forms with the needed calls"
+  [dfs ov form]
+  (cond
+   (-> form symbol? not) form
+   (is-var? form) `(get-value ~dfs ~(cell-name form))
+   (is-col-var? form) `(get-values ~dfs ~(cell-name form))
+   (is-old-var? form) `(get-old-value ~dfs ~ov ~(cell-name form))
+   :otherwise form))
+
+(defn- build-fun
+  "Build the closure needed to compute a cell"
+  [form]
+  (let [dfs (gensym "df_")
+        ov (gensym "old_")]
+    `(fn [~dfs ~ov] ~(postwalk (partial replace-symbol dfs ov) form))))
+
+(defn- get-deps
+  "Get the names of the dependent cells"
+  [form]
+  (let [step (fn [f]
+               (cond
+                (coll? f) (apply union f)
+                (-> f symbol? not) nil
+                (is-var? f) #{(cell-name f)}
+                (is-col-var? f) #{(cell-name f)}
+                (is-old-var? f) #{(cell-name f)}
+                :otherwise nil))]
+    (postwalk step form)))
+
+(defn build-standard-cell
+  "Builds a standard cell"
+  [name deps fun expr]
+  (with-meta (struct standard-cell name (ref *empty-value*) deps fun expr ::cell)
+             *meta*))
+
+(defn build-validator-cell
+  "Builds a validator cell"
+  [deps fun expr]
+  (with-meta (struct validator-cell ::validator deps fun expr ::validator-cell)
+             *meta*))
+
+(defmacro cell
+  "Build a standard cell, like this:
+
+    (cell fred
+       (* ?mary ?joe))
+
+   Which creates a cell named fred that is the product of a cell mary and cell joe
+
+   Or:
+
+    (cell joe
+      (apply * ?*sally))
+
+   Which creates a cell that applies * to the collection of all cells named sally
+
+   Or:
+
+    (cell :source fred 0)
+
+   Which builds a source cell fred with initial value 0
+
+   Or:
+
+     (cell :validator (when (< ?fred ?sally)
+                          (throwf \"%s must be greater than %s\" ?fred ?sally))
+
+   Which will perform the validation"
+  [type & data]
+  (cond
+   (symbol? type) (let [name type ; No type for standard cell
+                        expr (first data) ; we ignore extra data!
+                        deps (get-deps expr)
+                        fun (build-fun expr)]
+                    `(build-standard-cell '~name ~deps ~fun '~expr))
+   (= type :source) (let [[name init] data]
+                      `(build-source-cell '~name ~init))
+   (= type :validator) (let [[expr] data
+                             deps (get-deps expr)
+                             fun (build-fun expr)]
+                         `(build-validator-cell ~deps ~fun '~expr))))
+
+                         
+;;; Cell Display
+
+(defmulti display-cell
+  "A 'readable' form of the cell"
+  :cell-type)
+
+(defmethod display-cell ::source-cell
+  [cell]
+  (list 'cell :source (:name cell) (-> cell :value deref)))
+
+(defmethod display-cell ::cell
+  [cell]
+  (list 'cell (:name cell) (:display cell) (-> cell :value deref)))
+
+(defmethod display-cell ::validator-cell
+  [cell]
+  (list 'cell :validator (:display cell)))
+
+(defmethod print-method ::dataflow-cell
+  [f #^Writer w]
+  (binding [*out* w]
+    (pr (display-cell f))))
+
+
+;;; Evaluation
+
+(defmulti eval-cell
+  "Evaluate a dataflow cell.  Return [changed, old val]"
+  (fn [df data old cell] (:cell-type cell)))
+
+(defmethod eval-cell ::source-cell
+  [df data old cell]
+  (let [name (:name cell)
+        val (:value cell)
+        ov @val]
+    (if (contains? data name)
+      (let [new-val (data name)]
+        (if (not= ov new-val)
+          (do (ref-set val new-val)
+              [true ov])
+          [false ov]))
+      [false ov])))
+
+(defmethod eval-cell ::cell
+  [df data old cell]
+  (let [val (:value cell)
+        old-val @val
+        new-val ((:fun cell) df old)]
+    (if (not= old-val new-val)
+      (do (ref-set val new-val)
+          [true old-val])
+      [false old-val])))
+
+(defmethod eval-cell ::validator-cell
+  [df data old cell]
+  (do ((:fun cell) df old)
+      [false nil]))
+
+(defn- perform-flow
+  "Evaluate the needed cells (a set) from the given dataflow.  Data is
+   a name-value mapping of new values for the source cells"
+  [df data needed]
+  (loop [needed needed
+         tops (:topological @df)
+         old {}]
+    (let [now (first tops) ; Now is a set of nodes
+          new-tops (next tops)]
+      (when (and (-> needed empty? not)
+                 (-> now empty? not))
+        (let [step (fn [[needed old] cell]
+                     (let [[changed ov] (try
+                                         (eval-cell df data old cell)
+                                         (catch Exception e
+                                           (throw (Exception. (str cell) e))))]
+                       (if changed
+                         [(union needed (get-neighbors (:fore-graph @df) cell))
+                          (assoc old (:name cell) ov)]
+                         [needed old])))
+              [new-needed new-old] (reduce step
+                                           [needed old]
+                                           (intersection now needed))]
+          (recur new-needed new-tops new-old))))))
+         
+(defn- validate-update
+  "Ensure that all the updated cells are source cells"
+  [df names]
+  (let [scns (set (map :name (get-source-cells df)))]
+    (doseq [name names]
+      (when (-> name scns not)
+        (throwf Exception "Cell %n is not a source cell" name)))))
+        
+(defn update-values
+  "Given a dataflow, and a map of name-value pairs, update the
+   dataflow by binding the new values.  Each name must be of a source
+   cell"
+  [df data]
+  (dosync
+   (validate-update df (keys data))
+   (let [needed (apply union (for [name (keys data)]
+                               (set ((:cells-map @df) name))))]
+     (perform-flow df data needed))))
+
+(defn- initialize
+  "Apply all the current source cell values.  Useful for a new
+   dataflow, or one that has been updated with new cells"
+  [df]
+  (let [needed (:cells @df)
+        fg (:fore-graph @df)]
+    (perform-flow df {} needed)))
+
+
+;;; Watchers
+
+(defn add-cell-watcher
+  "Adds a watcher to a cell to respond to changes of value.  The is a
+   function of 4 values: a key, the cell, its old value, its new
+   value.  This is implemented using Clojure's add-watch to the
+   underlying ref, and shared its sematics"
+  [cell key fun]
+  (let [val (:value cell)]
+    (add-watch val key (fn [key _ old-v new-v]
+                         (fun key cell old-v new-v)))))
+
+
+(comment
+
+  (def df
+   (build-dataflow
+    [(cell :source fred 1)
+     (cell :source mary 0)
+     (cell greg (+ ?fred ?mary))
+     (cell joan (+ ?fred ?mary))
+     (cell joan (* ?fred ?mary))
+     (cell sally (apply + ?*joan))
+     (cell :validator (when (number? ?-greg)
+                        (when (<= ?greg ?-greg)
+                          (throwf Exception "Non monotonic"))))]))
+
+  (do (println)
+      (print-dataflow df))
+
+  (add-cell-watcher (get-cell df 'sally)
+                    nil
+                    (fn [key cell o n]
+                      (printf "sally changed from %s to %s\n" o n)))
+
+  (update-values df {'fred 1 'mary 1})
+  (update-values df {'fred 5 'mary 1})
+  (update-values df {'fred 0 'mary 0})
+
+  (get-value df 'fred)
+  (get-values df 'joan)
+  (get-value df 'sally)
+  (get-value df 'greg)
+
+  (use :reload 'jls.dataflow.dataflow)
+  (use 'clojure.contrib.stacktrace) (e)
+  (use 'clojure.contrib.trace)
+)
+    
+
+;; End of file
diff --git a/src/clojure/contrib/test_contrib.clj b/src/clojure/contrib/test_contrib.clj
index d3774b4a..15d8003f 100644
--- a/src/clojure/contrib/test_contrib.clj
+++ b/src/clojure/contrib/test_contrib.clj
@@ -15,7 +15,7 @@
 (ns clojure.contrib.test-contrib
   (:use clojure.contrib.test-is))
 
-(def tests [:str-utils :shell-out :test-graph])
+(def tests [:str-utils :shell-out :test-graph :test-dataflow])
 
 (defn test-name
   [test]
diff --git a/src/clojure/contrib/test_contrib/test_dataflow.clj b/src/clojure/contrib/test_contrib/test_dataflow.clj
new file mode 100644
index 00000000..f44a9934
--- /dev/null
+++ b/src/clojure/contrib/test_contrib/test_dataflow.clj
@@ -0,0 +1,90 @@
+;;  Copyright (c) Jeffrey Straszheim. All rights reserved.  The use and
+;;  distribution terms for this software are covered by the Eclipse Public
+;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
+;;  be found in the file epl-v10.html at the root of this distribution.  By
+;;  using this software in any fashion, you are agreeing to be bound by the
+;;  terms of this license.  You must not remove this notice, or any other,
+;;  from this software.
+;;
+;;  test-dataflow
+;;
+;;  A Library to Support a Dataflow Model of State - Tests
+;;
+;;  straszheimjeffrey (gmail)
+;;  Created 11 March 2009
+
+
+(ns clojure.contrib.test-contrib.test-dataflow
+  (:use clojure.contrib.test-is)
+  (:use clojure.contrib.dataflow))
+
+(def df-1
+     (build-dataflow
+      [(cell :source base 0)
+       (cell :source items ())
+       (cell product (* ?base (apply + ?items)))
+       (cell :validator (when (number? ?-product)
+                          (assert (>= ?product ?-product))))]))
+
+(deftest test-df-1
+  (is (= (get-value df-1 'product) 0))
+  (is (do (update-values df-1 {'items [4 5]})
+          (= (get-value df-1 'product) 0)))
+  (is (do (update-values df-1 {'base 2})
+          (= (get-value df-1 'product) 18)))
+  (is (thrown? Exception (update-values df-1 {'base 0})))
+  (is (= (get-value df-1 'product) 18)))
+
+(def df-2
+     (build-dataflow
+      [(cell :source strength 10)
+       (cell :source agility 10)
+       (cell :source magic 10)
+
+       (cell total-cost (apply + ?*cost))
+
+       (cell cost (- ?strength 10))
+       (cell cost (- ?agility 10))
+       (cell cost (- ?magic 10))
+
+       (cell combat (+ ?strength ?agility ?combat-mod))
+       (cell speed (+ ?agility (/ ?strength 10.0) ?speed-mod))
+       (cell casting (+ ?agility ?magic ?magic-mod))
+
+       (cell combat-mod (apply + ?*combat-mods))
+       (cell speed-mod (apply + ?*speed-mods))
+       (cell magic-mod (apply + ?*magic-mods))]))
+
+(def magic-skill
+     [(cell cost 5)
+      (cell speed-mods 1)
+      (cell magic-mods 2)])
+
+(defn gv [n] (get-value df-2 n))
+
+(deftest test-df-2
+  (is (and (= (gv 'total-cost) 0)
+           (= (gv 'strength) 10)
+           (= (gv 'casting) 20)))
+  (is (do (update-values df-2 {'magic 12})
+          (and (= (gv 'total-cost) 2)
+               (= (gv 'casting) 22))))
+  (is (do (add-cells df-2 magic-skill)
+          (and (= (gv 'total-cost) 7)
+               (= (gv 'casting) 24))))
+  (is (do (remove-cells df-2 magic-skill)
+          (and (= (gv 'total-cost) 2)
+               (= (gv 'casting) 22)))))
+               
+
+(comment
+  (run-tests)
+
+  (use :reload 'jls.dataflow.dataflow)
+  (use 'clojure.contrib.stacktrace) (e)
+  (use 'clojure.contrib.trace)
+
+)
+
+
+;; End of file