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