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