-
Notifications
You must be signed in to change notification settings - Fork 82
/
dataflow.clj
508 lines (407 loc) · 14.1 KB
/
dataflow.clj
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
;; 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
#^{:author "Jeffrey Straszheim",
:doc "A library to support a dataflow model of state"}
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.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 source-cell?
"Is this cell a source cell?"
[cell]
(isa? (:cell-type cell) ::source-cell))
(defn get-source-cells
"Returns a collection of source cells from the dataflow"
[df]
(for [cell (:cells @df)
:when (source-cell? 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))))
nn (disj needed cell)]
(if changed
[(union nn (get-neighbors (:fore-graph @df) cell))
(assoc old (:name cell) ov)]
[nn 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 'clojure.contrib.dataflow)
(use 'clojure.stacktrace) (e)
(use 'clojure.contrib.trace)
)
;; End of file