Update of /project/cells/cvsroot/arccells In directory clnet:/tmp/cvs-serv11249
Added Files: arccells-its-alive.arc Log Message:
--- /project/cells/cvsroot/arccells/arccells-its-alive.arc 2008/02/19 02:38:06 NONE +++ /project/cells/cvsroot/arccells/arccells-its-alive.arc 2008/02/19 02:38:06 1.1 ;; ;; copyright 2008 by Kenny Tilton ;; ;; License: MIT Open Source ;; ;;
;;; --- detritus ------------ ;;;
(def prt args ; why on earth does prn run the output together? (apply prs args) (prn))
(def tablemap (table fn) ; fns are always huge and then a tiny little table ref just hangs off the end (maptable fn table) table)
(def cadrif (x) (when (acons x) (cadr x)))
(mac withs* (parms . body) ; faux dynamic binding (let uparms (map1 [cons (uniq) _] (pair parms)) `(do ,@(map1 (fn ((save curr val)) `(= ,save ,curr ,curr ,val)) uparms) (do1 (do ,@body) ,@(map1 (fn ((save curr val)) `(= ,curr ,save)) uparms)))))
;;; -------------------- Cells ---------------------- ;;; ;;; A partial implementation of the Cells Manifesto: ;;; http://smuglispweeny.blogspot.com/2008/02/cells-manifesto.html ;;; ;;; --- globals --------------------
(= datapulse* 0) ;; "clock" used to ensure synchronization/data integrity (= caller* nil) ;; cell whose rule is currently running, if any (= mds* (table)) ;; model dictionary (= obs* (table)) ;; global "observer" dictionary
;;; --- md -> modelling ----------------------------------------
(mac defmd ((type-name (o includes) (o pfx (string type-name "-"))) . slot-defs) `(do (deftem (,type-name ,@includes) ctype ',type-name cells nil ,@(mappend (fn (sd) (list (carif sd)(cadrif sd))) slot-defs)) ; define readers ,@(map (fn (sd) `(def ,(coerce (+ (string pfx) (string sd)) 'sym) (i) (slot-value i ',sd))) (map carif slot-defs)) ; define writers ,@(map (fn (sd) `(def ,(coerce (+ "set-" (string pfx) (string sd)) 'sym) (i v) (set-slot-value i ',sd v))) (map carif slot-defs))))
;;; --- model initialization
(def to-be (i) (do1 i (md-finalize i) (md-awaken i)))
(def md-finalize (i) (do1 i (if (acons i) (map md-finalize i) (do ; register instance in a namespace for inter-i dependency (= (mds* (md-name i)) i)
; move cells out of mediated slots into 'cells slot (tablemap i (fn (k v) (when (c-isa v 'cell) (= v!model i v!slot k) (push (list k v) i!cells) (= (i k) 'unbound))))))))
(def md-awaken (i) (do1 i (if (acons i) (map md-awaken i) (do ; bring each slot "to life" (tablemap i (fn (k v) (aif (md-slot-cell i k) (slot-ensure-current it) (slot-value-observe i k v 'unbound))))))))
(def md? (name) mds*.name)
;; --- start of cells stuff ------------------
(def cells-reset () (= datapulse* 1) ; not sure why can't start at zero (= caller* nil) (= mds* (table)))
(def ctype-of (x) (when (isa x 'table) x!ctype))
(def c-isa (s type) (is ctype-of.s type))
(defmd (cell nil c-) ;; the c- gets prefixed to all accessor names awake (pulse 0) (pulse-last-changed 0) (cache 'unbound) model slot rule users useds observers)
(defmd (model nil md-) ; any template to be mediated by cells must include model name ; used so one instance can find another by name cells observers)
(def md-slot-cell (i s) (alref i!cells s))
;;; --- reading a slot -------------------------
(def slot-value (i s) (aif (md-slot-cell i s) (do (when caller* (pushnew caller* it!users) (pushnew it caller*!useds)) (slot-ensure-current it)) (i s)))
(def calculate-and-set (c) ; clear dependencies so we get a fresh set after each rule run (each used c!useds (= used!users (rem c used!users))) (= c!useds nil)
; run the rule (let nv (withs* (caller* c) (c!rule c!model)) (unless c!useds ; losing rules with no dependencies ; is a big performance win (optimize-away c)) (slot-value-assume c nv)))
(def optimize-away (c) (pull (assoc c!slot ((c-model c) 'cells)) ((c-model c) 'cells)) (each user c!users (pull c user!useds) (unless user!useds ; rarely happens (optimize-away user))))
(def slot-ensure-current (c) ; It would be fun to figure out a more readable ; version of the next consition. I tried, can't. (when (and c!rule (or (is 0 c!pulse-last-changed) (no (or (is c!pulse datapulse*) (no (any-used-changed c c!useds)))))) (calculate-and-set c))
(= c!pulse datapulse*)
(when (is 0 c!pulse-last-changed) ;; proxy for nascent state (= c!pulse-last-changed datapulse*) (slot-value-observe c!model c!slot c!cache 'unbound)) c!cache)
(def any-used-changed (c useds) (when useds ; So happens that FIFO is better order for this (or (any-used-changed c (cdr useds)) (let used (car useds) (slot-ensure-current used) (> used!pulse-last-changed c!pulse)))))
;;; --- writing to a slot -----------------------
(def set-slot-value (i s v) (aif (md-slot-cell i s) (do (++ datapulse*) (slot-value-assume it v)) (prt "you cannot assign to a slot without a cell" i s)))
(def slot-value-assume (c v) (= c!pulse datapulse*) (with (i c!model ov c!cache) (unless (is v ov) (= c!cache v) (= (i c!slot) v) (= c!pulse-last-changed datapulse*) (slot-propagate c ov))) v)
;;; --- dataflow -------------------------------- ;;; Propagate state change from cell to cell and ;;; as needed from Cell to outside world ;;; (def slot-propagate (c ov) (let caller* nil (each user c!users (slot-ensure-current user)) (slot-value-observe c!model c!slot c!cache ov)))
(def slot-value-observe (i s v ov) (awhen (md-slot-cell i s) (observe it!observers i s v ov)) (observe (alref i!observers s) i s v ov) (observe obs*.s i s v ov))
(def observe (o i s v ov) (if (acons o) (map (fn (o2) (o2 i s v ov)) o) o (o i s v ov)))
;;; --- constructor sugar --------------------
(mac imd (name (type) . inits) `(inst ',type 'name ',name ,@(mappend (fn ((s v)) `(',s ,v)) (pair inits))))
(def c-in (v) (inst 'cell 'cache v))
(mac c? (rule . observers) `(inst 'cell 'rule ,rule 'observers (list ,@observers)))
;;; --- example --------------------------------
(defmd (furnace (model) fur-) on temp (fuel 0) ;;; another way to do observers, at the class level ;;; observers `((fuel ,(fn (i s v ov) ;;; (prt 'md-defined-observer-sees i!name s v ov)))) )
(defmd (thermostat (model) thermo-) preferred actual)
(def test-furnace () (do (cells-reset) (prt '----------start-------------------) (let (th f) (to-be (list (imd th42 (thermostat) preferred (c-in 70) actual 70) (imd f-1 (furnace) fuel 10 on (c? [let th (md? 'th42) (< (thermo-actual th)(thermo-preferred th))] ; an instance-level observer (fn (i s v ov) (prt "Sending"(if v 'on 'off) "control sequence to furnace f-1")))))) ;;; A global observer of any slot called "on" ;;; (push (fn (i s v ov) ;;; (prt 'on-global-obs-1 i!name s v ov)) ;;; obs*!on)
(prt "After awakening the model the furnace is" (if (fur-on f) 'on 'off)) (set-thermo-preferred th 72) ;; the furnace comes on cuz we want it warmer )))
(test-furnace)
;;; Output: ; ----------start------------------- ; Sending off control sequence to furnace f-1 ; After awakening the model the furnace is off ; Sending on control sequence to furnace f-1