[cells-cvs] CVS arccells
ktilton
ktilton at common-lisp.net
Tue Feb 19 02:38:06 UTC 2008
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 , at 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 , at 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 , at 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
More information about the Cells-cvs
mailing list