[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:
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)

(def tablemap (table fn)
  ; fns are always huge and then a tiny little table ref just hangs off the end
  (maptable fn 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)
           (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)
       (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)
          ; 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)

;; --- 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)

(def c-isa (s type)
  (is ctype-of.s type))

(defmd (cell nil c-) ;; the c- gets prefixed to all accessor names
  (pulse 0)
  (pulse-last-changed 0)
  (cache 'unbound)

(defmd (model nil md-)
    ; any template to be mediated by cells must include model
  name ; used so one instance can find another by name

(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))

(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)))

;;; --- 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
                  (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


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