Monday, February 18, 2008

Arc!Cells: It's Alive!!!

In the Cells Manifesto I explained what all the Cells hoopla was about, including the vast array of other people doing the same thing only not as well as His Kennyness.

In the Baby Steps article we saw a primitive exploration of the mere beginnings of a partial implementation.

Well I am through kidding around! Below the fold you will find what should be standalone code for a solid Arc implementation (albeit not as fully splediferous as The Real (Common Lisp) Deal) of vanilla Cells. Also available from CVS.

The furnace example at the end will (a) provoke even more nutty ads for furnace installations (sigh) and provide a rough idea of the magic: make one state change and like so many dominoes other state change follows as effect follows cause, with user-defined observer callbacks invoked so our virtual models can act on the world outside the model, all under a declarative paradigm the academics call reactive programming because a better name like dataflow would not make them sound so... I digress.

Enjoy. Arc code enhancements always welcome, especially where I have reinvented built-in Arc constructs.

;; - - - - - - - - - - - - - cut here - - - - - - - - - - - - - -
;;
;; 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

6 comments:

Anonymous said...

Hi Kenny, in my version of ARC, if I define in WITHS*:
let uparms (map1 [cons (uniq) _] (pair parms))
I have this error:
"reference to undefined identifier: _uparms"
So, i modified this part of code in:
(= uparms (map1 [cons (uniq) _] (pair parms)))
and everything's start rolling..

Thank you again (for all)

rgc

Kenny Tilton said...

reference to undefined identifier: _uparms

I don't like making changes without understanding why something that should work does not -- there might be something else lurking, the fix might be an invitation to other problems, I do not learn anything, etc etc. You say "in my version" -- got some enhancements in there? I am working from arc1 unchanged and do not see a problem -- you might be missing a chance to make a bug report. One thing to do is figure out which reference is the problem by excising each of the two big chunks in turn. Lemme know.

Anonymous said...

Sorry, I'm not a programmer, and you're right... I have Paul's version of ARC posted in his forum 6 days ago:
http://ycombinator.com/arc/arc1.tar
The simply declaration of WITHS* gives me no problems; it's only when I (you) define:
(def calculate-and-set(c)....
......
(let nv(withs* (caller* c).....
that I have the message error:
"reference to undefined identifier: _uparms"
After I changed it as i said, everything's okay.
Let me know if you can understand what happens, and thank you again
rgc

Anonymous said...

Good Job! :)

Steve said...

Kenny,

What are the best locations to find the CL and arc versions of Cells? The CVS site at common-lisp.net is no longer resident.


Thanks, Steve

Kenny Tilton said...

Hey, Steve. A reasonably modern version of Cells is available via QuickLisp, which accesses GitHub: https://github.com/kennytilton/cells

The Arc version of cells is in the body of the post. You might consider the follow-up comments in case a new version of Arc breaks my code.

hth, ken

ps. You can find me at kentilton at gmail cot com for more agile support. :)