1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/contrib/dataflow.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,509 @@
     1.4 +;;  Copyright (c) Jeffrey Straszheim. All rights reserved.  The use and
     1.5 +;;  distribution terms for this software are covered by the Eclipse Public
     1.6 +;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
     1.7 +;;  be found in the file epl-v10.html at the root of this distribution.  By
     1.8 +;;  using this software in any fashion, you are agreeing to be bound by the
     1.9 +;;  terms of this license.  You must not remove this notice, or any other,
    1.10 +;;  from this software.
    1.11 +;;
    1.12 +;;  dataflow.clj
    1.13 +;;
    1.14 +;;  A Library to Support a Dataflow Model of State
    1.15 +;;
    1.16 +;;  straszheimjeffrey (gmail)
    1.17 +;;  Created 10 March 2009
    1.18 +
    1.19 +
    1.20 +(ns
    1.21 +  ^{:author "Jeffrey Straszheim",
    1.22 +     :doc "A library to support a dataflow model of state"}
    1.23 +  clojure.contrib.dataflow
    1.24 +  (:use [clojure.set :only (union intersection difference)])
    1.25 +  (:use [clojure.contrib.graph :only (directed-graph
    1.26 +                                      reverse-graph
    1.27 +                                      dependency-list
    1.28 +                                      get-neighbors)])
    1.29 +  (:use [clojure.walk :only (postwalk)])
    1.30 +  (:use [clojure.contrib.except :only (throwf)])
    1.31 +  (:import java.io.Writer))
    1.32 +
    1.33 +
    1.34 +;;; Chief Data Structures
    1.35 +
    1.36 +
    1.37 +;; Source Cell
    1.38 +
    1.39 +; The data of a source cell is directly set by a calling function.  It
    1.40 +; never depends on other cells.
    1.41 +
    1.42 +(defstruct source-cell
    1.43 +  :name             ; The name, a symbol
    1.44 +  :value            ; Its value, a Ref
    1.45 +  :cell-type)       ; Should be ::source-cell
    1.46 +
    1.47 +;; Cell
    1.48 +
    1.49 +; A standard cell that computes its value from other cells.
    1.50 +
    1.51 +(defstruct standard-cell
    1.52 +  :name            ; The name, a symbol
    1.53 +  :value           ; Its value, a Ref
    1.54 +  :dependents      ; The names of cells on which this depends, a collection
    1.55 +  :fun             ; A closure that computes the value, given an environment
    1.56 +  :display         ; The original expression for display
    1.57 +  :cell-type)      ; Should be ::cell
    1.58 +
    1.59 +(derive ::cell ::dependent-cell) ; A cell that has a dependents field
    1.60 +
    1.61 +;; Validator
    1.62 +
    1.63 +; A cell that has no value, but can throw an exception when run
    1.64 +
    1.65 +(defstruct validator-cell
    1.66 +  :name            ; Always ::validator
    1.67 +  :dependents      ; The names of cells on which this depends, a collection
    1.68 +  :fun             ; A clojure that can throw an exception
    1.69 +  :display         ; The original exprssion for display
    1.70 +  :cell-type)      ; Should be ::validator-cell
    1.71 +
    1.72 +(derive ::validator-cell ::dependent-cell)
    1.73 +
    1.74 +
    1.75 +;; A sentinal value
    1.76 +
    1.77 +(def *empty-value* (java.lang.Object.))
    1.78 +
    1.79 +
    1.80 +;; Dataflow
    1.81 +
    1.82 +; A collection of cells and dependency information
    1.83 +
    1.84 +(defstruct dataflow
    1.85 +  :cells          ; A set of all cells
    1.86 +  :cells-map      ; A map of cell names (symbols) to collections of cells
    1.87 +  :fore-graph     ; The inverse of the dependency graph, nodes are cells
    1.88 +  :topological)   ; A vector of sets of independent nodes -- orders the computation
    1.89 +
    1.90 +
    1.91 +;;; Environment Access
    1.92 +
    1.93 +(defn get-cells
    1.94 +  "Get all the cells named by name"
    1.95 +  [df name]
    1.96 +  ((:cells-map @df) name))
    1.97 +
    1.98 +(defn get-cell
    1.99 +  "Get the single cell named by name"
   1.100 +  [df name]
   1.101 +  (let [cells (get-cells df name)]
   1.102 +    (cond
   1.103 +     (= (count cells) 1) (first cells)
   1.104 +     (> (count cells) 1) (throwf Exception "Cell %s has multiple instances" name)
   1.105 +     :otherwise (throwf Exception "Cell %s is undefined" name))))
   1.106 +
   1.107 +(defn source-cell?
   1.108 +  "Is this cell a source cell?"
   1.109 +  [cell]
   1.110 +  (isa? (:cell-type cell) ::source-cell))
   1.111 +
   1.112 +(defn get-source-cells
   1.113 +  "Returns a collection of source cells from the dataflow"
   1.114 +  [df]
   1.115 +  (for [cell (:cells @df)
   1.116 +        :when (source-cell? cell)]
   1.117 +    cell))
   1.118 +
   1.119 +(defn get-value
   1.120 +  "Gets a value from the df matching the passed symbol.
   1.121 +   Signals an error if the name is not present, or if it not a single
   1.122 +   value."  
   1.123 +  [df name]
   1.124 +  (let [cell (get-cell df name)
   1.125 +        result @(:value cell)]
   1.126 +    (do (when (= *empty-value* result)
   1.127 +          (throwf Exception "Cell named %s empty" name))
   1.128 +        result)))
   1.129 +
   1.130 +(defn get-values
   1.131 +  "Gets a collection of values from the df by name"
   1.132 +  [df name]
   1.133 +  (let [cells (get-cells df name)
   1.134 +        results (map #(-> % :value deref) cells)]
   1.135 +    (do
   1.136 +      (when (some #(= % *empty-value*) results)
   1.137 +        (throwf Exception "At least one empty cell named %s found" name))
   1.138 +      results)))
   1.139 +
   1.140 +(defn get-old-value
   1.141 +  "Looks up an old value"
   1.142 +  [df env name]
   1.143 +  (if (contains? env name)
   1.144 +    (env name)
   1.145 +    (get-value df name)))
   1.146 +
   1.147 +(defn get-value-from-cell
   1.148 +  "Given a cell, get its value"
   1.149 +  [cell]
   1.150 +  (-> cell :value deref))
   1.151 +
   1.152 +;;; Build Dataflow Structure
   1.153 +
   1.154 +(defn- build-cells-map
   1.155 +  "Given a collection of cells, build a name->cells-collection map
   1.156 +   from it."
   1.157 +  [cs]
   1.158 +  (let [step (fn [m c]
   1.159 +               (let [n (:name c)
   1.160 +                     o (get m n #{})
   1.161 +                     s (conj o c)]
   1.162 +                 (assoc m n s)))]
   1.163 +    (reduce step {} cs)))
   1.164 +
   1.165 +(defn- build-back-graph
   1.166 +  "Builds the backward dependency graph from the cells map.  Each
   1.167 +   node of the graph is a cell."
   1.168 +  [cells cells-map]
   1.169 +  (let [step (fn [n]
   1.170 +               (apply union (for [dep-name (:dependents n)]
   1.171 +                              (cells-map dep-name))))
   1.172 +        neighbors (zipmap cells (map step cells))]
   1.173 +    (struct-map directed-graph
   1.174 +        :nodes cells
   1.175 +        :neighbors neighbors)))
   1.176 +
   1.177 +(defn- build-dataflow*
   1.178 +  "Builds the dataflow structure"
   1.179 +  [cs]
   1.180 +  (let [cells (set cs)
   1.181 +        cells-map (build-cells-map cs)
   1.182 +        back-graph (build-back-graph cells cells-map)
   1.183 +        fore-graph (reverse-graph back-graph)]
   1.184 +    (struct-map dataflow
   1.185 +      :cells cells
   1.186 +      :cells-map cells-map
   1.187 +      :fore-graph fore-graph
   1.188 +      :topological (dependency-list back-graph))))
   1.189 +
   1.190 +(def initialize)
   1.191 +
   1.192 +(defn build-dataflow
   1.193 +  "Given a collection of cells, build and return a dataflow object"
   1.194 +  [cs]
   1.195 +  (dosync
   1.196 +   (let [df (ref (build-dataflow* cs))]
   1.197 +     (initialize df)
   1.198 +     df)))
   1.199 +
   1.200 +
   1.201 +;;; Displaying a dataflow
   1.202 +
   1.203 +(defn print-dataflow
   1.204 +  "Prints a dataflow, one cell per line"
   1.205 +  [df]
   1.206 +  (println)
   1.207 +  (let [f (fn [cell] (-> cell :name str))]
   1.208 +    (doseq [cell (sort-by f (:cells @df))]
   1.209 +      (prn cell))))
   1.210 +
   1.211 +
   1.212 +;;; Modifying a Dataflow
   1.213 +
   1.214 +(defn add-cells
   1.215 +  "Given a collection of cells, add them to the dataflow."
   1.216 +  [df cells]
   1.217 +  (dosync
   1.218 +   (let [new-cells (union (set cells) (:cells @df))]
   1.219 +     (ref-set df (build-dataflow* new-cells))
   1.220 +     (initialize df))))
   1.221 +
   1.222 +(defn remove-cells
   1.223 +  "Given a collection of cells, remove them from the dataflow."
   1.224 +  [df cells]
   1.225 +  (dosync
   1.226 +   (let [new-cells (difference (:cells @df) (set cells))]
   1.227 +     (ref-set df (build-dataflow* new-cells))
   1.228 +     (initialize df))))
   1.229 +
   1.230 +
   1.231 +;;; Cell building
   1.232 +
   1.233 +(def *meta* {:type ::dataflow-cell})
   1.234 +
   1.235 +(defn build-source-cell
   1.236 +  "Builds a source cell"
   1.237 +  [name init]
   1.238 +  (with-meta (struct source-cell name (ref init) ::source-cell)
   1.239 +             *meta*))
   1.240 +
   1.241 +(defn- is-col-var?
   1.242 +  [symb]
   1.243 +  (let [name (name symb)]
   1.244 +    (and (= \? (first name))
   1.245 +         (= \* (second name)))))
   1.246 +
   1.247 +(defn- is-old-var?
   1.248 +  [symb]
   1.249 +  (let [name (name symb)]
   1.250 +    (and (= \? (first name))
   1.251 +         (= \- (second name)))))
   1.252 +
   1.253 +(defn- is-var?
   1.254 +  [symb]
   1.255 +  (let [name (name symb)]
   1.256 +    (and (= \? (first name))
   1.257 +         (-> symb is-col-var? not)
   1.258 +         (-> symb is-old-var? not))))
   1.259 +
   1.260 +(defn- cell-name
   1.261 +  [symb]
   1.262 +  `(quote ~(cond (is-var? symb) (-> symb name (.substring 1) symbol)
   1.263 +                 (or (is-col-var? symb)
   1.264 +                     (is-old-var? symb)) (-> symb name (.substring 2) symbol))))
   1.265 +
   1.266 +(defn- replace-symbol
   1.267 +  "Walk the from replacing the ?X forms with the needed calls"
   1.268 +  [dfs ov form]
   1.269 +  (cond
   1.270 +   (-> form symbol? not) form
   1.271 +   (is-var? form) `(get-value ~dfs ~(cell-name form))
   1.272 +   (is-col-var? form) `(get-values ~dfs ~(cell-name form))
   1.273 +   (is-old-var? form) `(get-old-value ~dfs ~ov ~(cell-name form))
   1.274 +   :otherwise form))
   1.275 +
   1.276 +(defn- build-fun
   1.277 +  "Build the closure needed to compute a cell"
   1.278 +  [form]
   1.279 +  (let [dfs (gensym "df_")
   1.280 +        ov (gensym "old_")]
   1.281 +    `(fn [~dfs ~ov] ~(postwalk (partial replace-symbol dfs ov) form))))
   1.282 +
   1.283 +(defn- get-deps
   1.284 +  "Get the names of the dependent cells"
   1.285 +  [form]
   1.286 +  (let [step (fn [f]
   1.287 +               (cond
   1.288 +                (coll? f) (apply union f)
   1.289 +                (-> f symbol? not) nil
   1.290 +                (is-var? f) #{(cell-name f)}
   1.291 +                (is-col-var? f) #{(cell-name f)}
   1.292 +                (is-old-var? f) #{(cell-name f)}
   1.293 +                :otherwise nil))]
   1.294 +    (postwalk step form)))
   1.295 +
   1.296 +(defn build-standard-cell
   1.297 +  "Builds a standard cell"
   1.298 +  [name deps fun expr]
   1.299 +  (with-meta (struct standard-cell name (ref *empty-value*) deps fun expr ::cell)
   1.300 +             *meta*))
   1.301 +
   1.302 +(defn build-validator-cell
   1.303 +  "Builds a validator cell"
   1.304 +  [deps fun expr]
   1.305 +  (with-meta (struct validator-cell ::validator deps fun expr ::validator-cell)
   1.306 +             *meta*))
   1.307 +
   1.308 +(defmacro cell
   1.309 +  "Build a standard cell, like this:
   1.310 +
   1.311 +    (cell fred
   1.312 +       (* ?mary ?joe))
   1.313 +
   1.314 +   Which creates a cell named fred that is the product of a cell mary and cell joe
   1.315 +
   1.316 +   Or:
   1.317 +
   1.318 +    (cell joe
   1.319 +      (apply * ?*sally))
   1.320 +
   1.321 +   Which creates a cell that applies * to the collection of all cells named sally
   1.322 +
   1.323 +   Or:
   1.324 +
   1.325 +    (cell :source fred 0)
   1.326 +
   1.327 +   Which builds a source cell fred with initial value 0
   1.328 +
   1.329 +   Or:
   1.330 +
   1.331 +     (cell :validator (when (< ?fred ?sally)
   1.332 +                          (throwf \"%s must be greater than %s\" ?fred ?sally))
   1.333 +
   1.334 +   Which will perform the validation"
   1.335 +  [type & data]
   1.336 +  (cond
   1.337 +   (symbol? type) (let [name type ; No type for standard cell
   1.338 +                        expr (first data) ; we ignore extra data!
   1.339 +                        deps (get-deps expr)
   1.340 +                        fun (build-fun expr)]
   1.341 +                    `(build-standard-cell '~name ~deps ~fun '~expr))
   1.342 +   (= type :source) (let [[name init] data]
   1.343 +                      `(build-source-cell '~name ~init))
   1.344 +   (= type :validator) (let [[expr] data
   1.345 +                             deps (get-deps expr)
   1.346 +                             fun (build-fun expr)]
   1.347 +                         `(build-validator-cell ~deps ~fun '~expr))))
   1.348 +
   1.349 +                         
   1.350 +;;; Cell Display
   1.351 +
   1.352 +(defmulti display-cell
   1.353 +  "A 'readable' form of the cell"
   1.354 +  :cell-type)
   1.355 +
   1.356 +(defmethod display-cell ::source-cell
   1.357 +  [cell]
   1.358 +  (list 'cell :source (:name cell) (-> cell :value deref)))
   1.359 +
   1.360 +(defmethod display-cell ::cell
   1.361 +  [cell]
   1.362 +  (list 'cell (:name cell) (:display cell) (-> cell :value deref)))
   1.363 +
   1.364 +(defmethod display-cell ::validator-cell
   1.365 +  [cell]
   1.366 +  (list 'cell :validator (:display cell)))
   1.367 +
   1.368 +(defmethod print-method ::dataflow-cell
   1.369 +  [f ^Writer w]
   1.370 +  (binding [*out* w]
   1.371 +    (pr (display-cell f))))
   1.372 +
   1.373 +
   1.374 +;;; Evaluation
   1.375 +
   1.376 +(defmulti eval-cell
   1.377 +  "Evaluate a dataflow cell.  Return [changed, old val]"
   1.378 +  (fn [df data old cell] (:cell-type cell)))
   1.379 +
   1.380 +(defmethod eval-cell ::source-cell
   1.381 +  [df data old cell]
   1.382 +  (let [name (:name cell)
   1.383 +        val (:value cell)
   1.384 +        ov @val]
   1.385 +    (if (contains? data name)
   1.386 +      (let [new-val (data name)]
   1.387 +        (if (not= ov new-val)
   1.388 +          (do (ref-set val new-val)
   1.389 +              [true ov])
   1.390 +          [false ov]))
   1.391 +      [false ov])))
   1.392 +
   1.393 +(defmethod eval-cell ::cell
   1.394 +  [df data old cell]
   1.395 +  (let [val (:value cell)
   1.396 +        old-val @val
   1.397 +        new-val ((:fun cell) df old)]
   1.398 +    (if (not= old-val new-val)
   1.399 +      (do (ref-set val new-val)
   1.400 +          [true old-val])
   1.401 +      [false old-val])))
   1.402 +
   1.403 +(defmethod eval-cell ::validator-cell
   1.404 +  [df data old cell]
   1.405 +  (do ((:fun cell) df old)
   1.406 +      [false nil]))
   1.407 +
   1.408 +(defn- perform-flow
   1.409 +  "Evaluate the needed cells (a set) from the given dataflow.  Data is
   1.410 +   a name-value mapping of new values for the source cells"
   1.411 +  [df data needed]
   1.412 +  (loop [needed needed
   1.413 +         tops (:topological @df)
   1.414 +         old {}]
   1.415 +    (let [now (first tops) ; Now is a set of nodes
   1.416 +          new-tops (next tops)]
   1.417 +      (when (and (-> needed empty? not)
   1.418 +                 (-> now empty? not))
   1.419 +        (let [step (fn [[needed old] cell]
   1.420 +                     (let [[changed ov] (try
   1.421 +                                         (eval-cell df data old cell)
   1.422 +                                         (catch Exception e
   1.423 +                                           (throw (Exception. (str cell) e))))
   1.424 +                           nn (disj needed cell)]
   1.425 +                       (if changed
   1.426 +                         [(union nn (get-neighbors (:fore-graph @df) cell))
   1.427 +                          (assoc old (:name cell) ov)]
   1.428 +                         [nn old])))
   1.429 +              [new-needed new-old] (reduce step
   1.430 +                                           [needed old]
   1.431 +                                           (intersection now needed))]
   1.432 +          (recur new-needed new-tops new-old))))))
   1.433 +         
   1.434 +(defn- validate-update
   1.435 +  "Ensure that all the updated cells are source cells"
   1.436 +  [df names]
   1.437 +  (let [scns (set (map :name (get-source-cells df)))]
   1.438 +    (doseq [name names]
   1.439 +      (when (-> name scns not)
   1.440 +        (throwf Exception "Cell %n is not a source cell" name)))))
   1.441 +        
   1.442 +(defn update-values
   1.443 +  "Given a dataflow, and a map of name-value pairs, update the
   1.444 +   dataflow by binding the new values.  Each name must be of a source
   1.445 +   cell"
   1.446 +  [df data]
   1.447 +  (dosync
   1.448 +   (validate-update df (keys data))
   1.449 +   (let [needed (apply union (for [name (keys data)]
   1.450 +                               (set ((:cells-map @df) name))))]
   1.451 +     (perform-flow df data needed))))
   1.452 +
   1.453 +(defn- initialize
   1.454 +  "Apply all the current source cell values.  Useful for a new
   1.455 +   dataflow, or one that has been updated with new cells"
   1.456 +  [df]
   1.457 +  (let [needed (:cells @df)
   1.458 +        fg (:fore-graph @df)]
   1.459 +    (perform-flow df {} needed)))
   1.460 +
   1.461 +
   1.462 +;;; Watchers
   1.463 +
   1.464 +(defn add-cell-watcher
   1.465 +  "Adds a watcher to a cell to respond to changes of value.  The is a
   1.466 +   function of 4 values: a key, the cell, its old value, its new
   1.467 +   value.  This is implemented using Clojure's add-watch to the
   1.468 +   underlying ref, and shared its sematics"
   1.469 +  [cell key fun]
   1.470 +  (let [val (:value cell)]
   1.471 +    (add-watch val key (fn [key _ old-v new-v]
   1.472 +                         (fun key cell old-v new-v)))))
   1.473 +
   1.474 +
   1.475 +(comment
   1.476 +
   1.477 +  (def df
   1.478 +   (build-dataflow
   1.479 +    [(cell :source fred 1)
   1.480 +     (cell :source mary 0)
   1.481 +     (cell greg (+ ?fred ?mary))
   1.482 +     (cell joan (+ ?fred ?mary))
   1.483 +     (cell joan (* ?fred ?mary))
   1.484 +     (cell sally (apply + ?*joan))
   1.485 +     (cell :validator (when (number? ?-greg)
   1.486 +                        (when (<= ?greg ?-greg)
   1.487 +                          (throwf Exception "Non monotonic"))))]))
   1.488 +
   1.489 +  (do (println)
   1.490 +      (print-dataflow df))
   1.491 +
   1.492 +  (add-cell-watcher (get-cell df 'sally)
   1.493 +                    nil
   1.494 +                    (fn [key cell o n]
   1.495 +                      (printf "sally changed from %s to %s\n" o n)))
   1.496 +
   1.497 +  (update-values df {'fred 1 'mary 1})
   1.498 +  (update-values df {'fred 5 'mary 1})
   1.499 +  (update-values df {'fred 0 'mary 0})
   1.500 +
   1.501 +  (get-value df 'fred)
   1.502 +  (get-values df 'joan)
   1.503 +  (get-value df 'sally)
   1.504 +  (get-value df 'greg)
   1.505 +
   1.506 +  (use :reload 'clojure.contrib.dataflow)
   1.507 +  (use 'clojure.stacktrace) (e)
   1.508 +  (use 'clojure.contrib.trace)
   1.509 +)
   1.510 +    
   1.511 +
   1.512 +;; End of file