/[cells]/arccells/arccells-its-alive.arc
ViewVC logotype

Contents of /arccells/arccells-its-alive.arc

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Tue Feb 19 17:08:42 2008 UTC (6 years, 1 month ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +30 -25 lines
Use defset on slot writers to support (= (myslt x) 42)
1 ;;
2 ;; copyright 2008 by Kenny Tilton
3 ;;
4 ;; License: MIT Open Source
5 ;;
6 ;;
7
8 ;;; --- detritus ------------
9 ;;;
10
11 (def prt args
12 ; why on earth does prn run the output together?
13 (apply prs args)
14 (prn))
15
16 (def tablemap (table fn)
17 ; fns are always huge and then a tiny little table ref just hangs off the end
18 (maptable fn table)
19 table)
20
21 (def cadrif (x) (when (acons x) (cadr x)))
22
23 (mac withs* (parms . body)
24 ; faux dynamic binding
25 (let uparms (map1 [cons (uniq) _] (pair parms))
26 `(do ,@(map1 (fn ((save curr val))
27 `(= ,save ,curr ,curr ,val)) uparms)
28 (do1
29 (do ,@body)
30 ,@(map1 (fn ((save curr val))
31 `(= ,curr ,save)) uparms)))))
32
33 ;;; -------------------- Cells ----------------------
34 ;;;
35 ;;; A partial implementation of the Cells Manifesto:
36 ;;; http://smuglispweeny.blogspot.com/2008/02/cells-manifesto.html
37 ;;;
38 ;;; --- globals --------------------
39
40 (= datapulse* 0) ;; "clock" used to ensure synchronization/data integrity
41 (= caller* nil) ;; cell whose rule is currently running, if any
42 (= mds* (table)) ;; model dictionary
43 (= obs* (table)) ;; global "observer" dictionary
44
45 ;;; --- md -> modelling ----------------------------------------
46
47 (mac defmd ((type-name (o includes)
48 (o pfx (string type-name "-")))
49 . slot-defs)
50 `(do
51 (deftem (,type-name ,@includes)
52 ctype ',type-name
53 cells nil
54 ,@(mappend (fn (sd) (list (carif sd)(cadrif sd))) slot-defs))
55 ; define readers
56 ,@(mappend (fn (sd)
57 (withs (rdr$ (+ (string pfx) (string sd))
58 rdr (coerce rdr$ 'sym)
59 wrtr (coerce (+ "set-" rdr$) 'sym))
60 `((def ,rdr (i)
61 (slot-value i ',sd))
62 (def ,wrtr (i v)
63 (set-slot-value i ',sd v))
64 (defset ,rdr (x)
65 (w/uniq g
66 (list (list g x)
67 `(,',rdr ,g)
68 `(fn (val) (,',wrtr ,g val))))))))
69 (map carif slot-defs))))
70
71 ;;; --- model initialization
72
73 (def to-be (i)
74 (do1 i
75 (md-finalize i)
76 (md-awaken i)))
77
78 (def md-finalize (i)
79 (do1 i
80 (if (acons i)
81 (map md-finalize i)
82 (do
83 ; register instance in a namespace for inter-i dependency
84 (= (mds* (md-name i)) i)
85
86 ; move cells out of mediated slots into 'cells slot
87 (tablemap i
88 (fn (k v)
89 (when (c-isa v 'cell)
90 (= v!model i v!slot k)
91 (push (list k v) i!cells)
92 (= (i k) 'unbound))))))))
93
94 (def md-awaken (i)
95 (do1 i
96 (if (acons i)
97 (map md-awaken i)
98 (do ; bring each slot "to life"
99 (tablemap i
100 (fn (k v)
101 (aif (md-slot-cell i k)
102 (slot-ensure-current it)
103 (slot-value-observe i k v 'unbound))))))))
104
105 (mac md? (name)
106 `(mds* ',name))
107
108 ;; --- start of cells stuff ------------------
109
110 (def cells-reset ()
111 (= datapulse* 1) ; not sure why can't start at zero
112 (= caller* nil)
113 (= mds* (table)))
114
115 (def ctype-of (x)
116 (when (isa x 'table)
117 x!ctype))
118
119 (def c-isa (s type)
120 (is ctype-of.s type))
121
122 (defmd (cell nil c-) ;; the c- gets prefixed to all accessor names
123 awake
124 (pulse 0)
125 (pulse-last-changed 0)
126 (cache 'unbound)
127 model
128 slot
129 rule
130 users
131 useds
132 observers)
133
134 (defmd (model nil md-)
135 ; any template to be mediated by cells must include model
136 name ; used so one instance can find another by name
137 cells
138 observers)
139
140 (def md-slot-cell (i s)
141 (alref i!cells s))
142
143 ;;; --- reading a slot -------------------------
144
145 (def slot-value (i s)
146 (aif (md-slot-cell i s)
147 (do (when caller*
148 (pushnew caller* it!users)
149 (pushnew it caller*!useds))
150 slot-ensure-current.it)
151 (i s)))
152
153 (def calculate-and-set (c)
154 ; clear dependencies so we get a fresh set after each rule run
155 (each used c!useds
156 (= used!users (rem c used!users)))
157 (= c!useds nil)
158
159 ; run the rule
160 (let nv (withs* (caller* c)
161 (c!rule c!model))
162 (unless c!useds
163 ; losing rules with no dependencies
164 ; is a big performance win
165 optimize-away.c)
166 (slot-value-assume c nv)))
167
168 (def optimize-away (c)
169 (pull (assoc c!slot ((c-model c) 'cells)) ((c-model c) 'cells))
170 (each user c!users
171 (pull c user!useds)
172 (unless user!useds ; rarely happens
173 optimize-away.user)))
174
175 (def slot-ensure-current (c)
176 ; It would be fun to figure out a more readable
177 ; version of the next consition. I tried, can't.
178 (when (and c!rule
179 (or (is 0 c!pulse-last-changed)
180 ~(or (is c!pulse datapulse*)
181 (~any-used-changed c c!useds))))
182 calculate-and-set.c)
183
184 (= c!pulse datapulse*)
185
186 (when (is 0 c!pulse-last-changed) ;; proxy for nascent state
187 (= c!pulse-last-changed datapulse*)
188 (slot-value-observe c!model c!slot c!cache 'unbound))
189 c!cache)
190
191 (def any-used-changed (c useds)
192 (when useds
193 ; So happens that FIFO is better order for this
194 (or (any-used-changed c (cdr useds))
195 (let used car.useds
196 slot-ensure-current.used
197 (> used!pulse-last-changed c!pulse)))))
198
199 ;;; --- writing to a slot -----------------------
200
201 (def set-slot-value (i s v)
202 (aif (md-slot-cell i s)
203 (do (++ datapulse*)
204 (slot-value-assume it v))
205 (prt "you cannot assign to a slot without a cell" i s)))
206
207 (def slot-value-assume (c v)
208 (= c!pulse datapulse*)
209 (with (i c!model ov c!cache)
210 (unless (is v ov)
211 (= c!cache v)
212 (= (i c!slot) v)
213 (= c!pulse-last-changed datapulse*)
214 (slot-propagate c ov)))
215 v)
216
217 ;;; --- dataflow --------------------------------
218 ;;; Propagate state change from cell to cell and
219 ;;; as needed from Cell to outside world
220 ;;;
221 (def slot-propagate (c ov)
222 (let caller* nil
223 (each user c!users
224 slot-ensure-current.user)
225 (slot-value-observe c!model c!slot c!cache ov)))
226
227 (def slot-value-observe (i s v ov)
228 (awhen (md-slot-cell i s)
229 (observe it!observers i s v ov))
230 (observe (alref i!observers s) i s v ov)
231 (observe obs*.s i s v ov))
232
233 (def observe (o i s v ov)
234 (if acons.o
235 (map [_ i s v ov] o)
236 o (o i s v ov)))
237
238 ;;; --- constructor sugar --------------------
239
240 (mac imd (name (type) . inits)
241 `(inst ',type 'name ',name
242 ,@(mappend (fn ((s v)) `(',s ,v)) (pair inits))))
243
244 (def c-in (v)
245 (inst 'cell 'cache v))
246
247 (mac c? (rule . observers)
248 `(inst 'cell
249 'rule ,rule
250 'observers (list ,@observers)))
251
252 ;;; --- example --------------------------------
253
254 (defmd (furnace (model) fur-)
255 on temp (fuel 0)
256 ;;; another way to do observers, at the class level
257 ;;; observers `((fuel ,(fn (i s v ov)
258 ;;; (prt 'md-defined-observer-sees i!name s v ov))))
259 )
260
261 (defmd (thermostat (model) thermo-)
262 preferred actual)
263
264 (def test-furnace ()
265 (do (cells-reset)
266 (prt '----------start-------------------)
267 (let (th f) (to-be
268 (list
269 (imd th42 (thermostat) preferred (c-in 70) actual 70)
270 (imd f-1 (furnace)
271 fuel 10 ;; unused for now
272 on (c? [let th (md? th42)
273 (< (thermo-actual th)(thermo-preferred th))]
274 ; an instance-level observer
275 (fn (i s v ov)
276 (prt "Sending"(if v 'on 'off) "control sequence to furnace f-1"))))))
277 ;;; A global observer of any slot called "on"
278 ;;; (push (fn (i s v ov)
279 ;;; (prt 'on-global-obs-1 i!name s v ov))
280 ;;; obs*!on)
281
282 (prt "After awakening the model the furnace is" (if (fur-on f) 'on 'off))
283 (= (thermo-preferred th) 72) ;; the furnace comes on cuz we want it warmer
284 )))
285
286 (test-furnace)
287
288 ;;; Output:
289 ; ----------start-------------------
290 ; Sending off control sequence to furnace f-1
291 ; After awakening the model the furnace is off
292 ; Sending on control sequence to furnace f-1

  ViewVC Help
Powered by ViewVC 1.1.5