[cells-cvs] CVS arccells

[ktilton]

Update of /project/cells/cvsroot/arccells
In directory clnet:/tmp/cvs-serv5046

Modified Files:
	arccells-its-alive.arc 
Log Message:
Use defset on slot writers to support (= (myslt x) 42)

--- /project/cells/cvsroot/arccells/arccells-its-alive.arc	2008/02/19 02:38:06	1.1
+++ /project/cells/cvsroot/arccells/arccells-its-alive.arc	2008/02/19 17:08:42	1.2
@@ -53,15 +53,20 @@
          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))))
+       ,@(mappend (fn (sd)
+                    (withs (rdr$ (+ (string pfx) (string sd))
+                             rdr (coerce rdr$ 'sym)
+                             wrtr (coerce (+ "set-" rdr$) 'sym))
+                      `((def ,rdr (i)
+                          (slot-value i ',sd))
+                        (def ,wrtr (i v)
+                          (set-slot-value i ',sd v))
+                        (defset ,rdr (x)
+                          (w/uniq g
+                            (list (list g x)
+                              `(,',rdr ,g)
+                              `(fn (val) (,',wrtr ,g val))))))))
+           (map carif slot-defs))))
 
 ;;; --- model initialization
 
@@ -97,8 +102,8 @@
                 (slot-ensure-current it)
                 (slot-value-observe i k v 'unbound))))))))
 
-(def md? (name)
-  mds*.name)
+(mac md? (name)
+  `(mds* ',name))
 
 ;; --- start of cells stuff ------------------
 
@@ -142,7 +147,7 @@
     (do (when caller*
           (pushnew caller* it!users)
           (pushnew it caller*!useds))
-        (slot-ensure-current it))
+        slot-ensure-current.it)
     (i s)))
 
 (def calculate-and-set (c)
@@ -157,7 +162,7 @@
     (unless c!useds
       ; losing rules with no dependencies 
       ; is a big performance win
-      (optimize-away c))
+      optimize-away.c)
     (slot-value-assume c nv)))
 
 (def optimize-away (c)
@@ -165,16 +170,16 @@
   (each user c!users
     (pull c user!useds)
     (unless user!useds ; rarely happens
-      (optimize-away user))))
+      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))
+            ~(or (is c!pulse datapulse*)
+               (~any-used-changed c c!useds))))
+    calculate-and-set.c)
 
   (= c!pulse datapulse*)
 
@@ -187,8 +192,8 @@
   (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)
+      (let used car.useds
+        slot-ensure-current.used
         (> used!pulse-last-changed c!pulse)))))
 
 ;;; --- writing to a slot -----------------------
@@ -216,7 +221,7 @@
 (def slot-propagate (c ov)
   (let caller* nil
     (each user c!users
-      (slot-ensure-current user))
+      slot-ensure-current.user)
     (slot-value-observe c!model c!slot c!cache ov)))
 
 (def slot-value-observe (i s v ov)
@@ -226,8 +231,8 @@
   (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)
+  (if acons.o
+      (map [_ i s v ov] o)
     o (o i s v ov)))
 
 ;;; --- constructor sugar --------------------
@@ -263,8 +268,8 @@
                  (list
                   (imd th42 (thermostat) preferred (c-in 70) actual 70)
                   (imd f-1 (furnace) 
-                    fuel 10
-                    on (c? [let th (md? 'th42)
+                    fuel 10 ;; unused for now
+                    on (c? [let th (md? th42)
                              (< (thermo-actual th)(thermo-preferred th))]
                          ; an instance-level observer
                          (fn (i s v ov)
@@ -275,7 +280,7 @@
       ;;;        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
+      (= (thermo-preferred th) 72) ;; the furnace comes on cuz we want it warmer
       )))
 
 (test-furnace)