Beginnings of tutorial/porting suite of demonstration/example/regress…

…ion test code. Also, a fix to core Cells so rules can happen to return multiple values (say by using ROUND as the last form) without tripping over Synapse-handling.

cells-test/df-interference.lisp

@@ -118,11 +118,3 @@
     ))
 
 
-(defmodel skipper ()
-  ((price :initform (c-in 0) :accessor price)
-   (max-price :accessor max-price
-     :initform (c? (if .cache
-                       (max (^price) .cache)
-                     (^price))))
-   (half-max :accessor half-max
-     :initform (c? (floor (^half-max)

cells-test/test.lisp

@@ -98,17 +98,21 @@ subclass for them?)
   ()
   (:default-initargs
       :md-value (c? (bwhen (ks (^kids))
+                      ;(trc "chya" (mapcar 'md-value ks))
                       (apply '+ (mapcar 'md-value ks))))))
 
 (def-cell-test many-useds
-    (with-integrity ()
-      (let ((i (make-instance 'm-index)))
-        (loop for n below 100
-            do (push (make-instance 'model
-                       :fm-parent i
-                       :md-value (c-in n))
-                 (kids i)))
-        (trc "index total" (md-value i)))))
+    (let ((i (make-instance 'm-index)))
+      (loop for n below 100
+          do (push (make-instance 'model
+                     :fm-parent i
+                     :md-value (c-in n))
+               (kids i)))
+      (trc "index total" (md-value i))
+      (ct-assert (= 4950 (md-value i)))))
+
+#+test
+(many-useds)
 
 (defmodel m-null ()
   ((aa :initform nil :cell nil :initarg :aa :accessor aa)))

cells.asd

@@ -8,7 +8,7 @@
     :name "cells"
   :author "Kenny Tilton <kentilton@gmail.com>"
   :maintainer "Kenny Tilton <kentilton@gmail.com>"
-  :licence "MIT Style"
+  :licence "Lisp LGPL"
   :description "Cells"
   :long-description "Cells: a dataflow extension to CLOS."
   :serial t

cells.lisp

@@ -84,11 +84,11 @@ See the Lisp Lesser GNU Public License for more details.
 (define-condition unbound-cell (unbound-slot) ())
 
 (defgeneric slot-value-observe (slotname self new old old-boundp)
-  #-(or cormanlisp clisp)
+  #-(or cormanlisp)
   (:method-combination progn))
 
 #-cells-testing
-(defmethod slot-value-observe #-(or cormanlisp clisp) progn
+(defmethod slot-value-observe #-(or cormanlisp) progn
   (slot-name self new old old-boundp)
   (declare (ignorable slot-name self new old old-boundp)))
 

cells.lpr

@@ -27,9 +27,7 @@
                  (make-instance 'module :name
                                 "doc\\01-Cell-basics.lisp")
                  (make-instance 'module :name
-                                "doc\\motor-control.lisp")
-                 (make-instance 'module :name
-                                "porting\\do-no-harm.lisp"))
+                                "doc\\motor-control.lisp"))
   :projects (list (make-instance 'project-module :name
                                  "utils-kt\\utils-kt"))
   :libraries nil

md-slot-value.lisp

@@ -191,9 +191,9 @@ See the Lisp Lesser GNU Public License for more details.
 
         ; --- data flow propagation -----------
         ;
-        (trc nil "md-sv comparing no-prop" c prior-state absorbed-value prior-value)
+        (trc nil "md-sv testing propagation" c propagation-code prior-state absorbed-value prior-value)
         (if (or (eq propagation-code :no-propagate) ;; possible if c is a cell serving as a synapse between two cells
-              (and (null propagation-code)
+              (and (not (eq propagation-code :propagate))
                 (eql prior-state :valid)
                 (c-no-news c absorbed-value prior-value)))
             (progn

propagate.lisp

@@ -119,7 +119,7 @@ See the Lisp Lesser GNU Public License for more details.
        ,(if (eql (last1 output-body) :test)
             (let ((temp1 (gensym))
                   (loc-self (gensym)))
-              `(defmethod slot-value-observe #-(or clisp cormanlisp) ,(if aroundp :around 'progn)
+              `(defmethod slot-value-observe #-(or cormanlisp) ,(if aroundp :around 'progn)
                  ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp)
                  (let ((,temp1 (bump-output-count ,slotname))
                        (,loc-self ,(if (listp self-arg)
@@ -129,7 +129,7 @@ See the Lisp Lesser GNU Public License for more details.
                      (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg))
                    (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg))))
           `(defmethod slot-value-observe
-               #-(or clisp cormanlisp) ,(if aroundp :around 'progn)
+               #-(or cormanlisp) ,(if aroundp :around 'progn)
              ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp)
              (declare (ignorable
                        ,@(flet ((arg-name (arg-spec)
@@ -138,9 +138,7 @@ See the Lisp Lesser GNU Public License for more details.
                                     (atom arg-spec))))
                            (list (arg-name self-arg)(arg-name new-varg)
                              (arg-name oldvarg)(arg-name oldvargboundp)))))
-             ,@output-body
-             ;;broke cells-gtk #+(or clisp cormanlisp) (call-next-method)
-             )))))
+             ,@output-body)))))
 
 (defmacro bump-output-count (slotname) ;; pure test func
   `(if (get ',slotname :outputs)

tutorial/01-lesson.lisp

@@ -0,0 +1,40 @@
+(defmacro cells::ct-assert (form &rest stuff)
+  `(progn
+     (print `(attempting ,',form))
+    (assert ,form () "Error with ~a >> ~a" ',form (list ,@stuff))))
+
+(defpackage #:tu-selfinit (:use :cl :cells))
+
+;;
+;; We will keep making new packages so we can incrementally develop the
+;; same class without newer versions stomping on earlier versions (by
+;; being in the same package and effectively redefining earlier versions).
+;;
+(in-package #:tu-selfinit)
+
+(defmodel rectangle ()
+  ((len :initarg :len :accessor len
+     :initform (c? (* 2 (width self))))
+   (width :initarg :width :initform nil :accessor width))
+  (:default-initargs
+      :width (c? (/ (len self) 2))))
+
+#+test
+(cells::ct-assert (eql 21 (width (make-instance 'rectangle :len 42))))
+
+;;; The first thing we see is that we are not creating something new, we are
+;;; merely /extending/ CLOS. defmodel works like defclass in all ways, except for
+;;; extensions to provide the behavior of Cells. We see both :initform
+;;; and :default-initarg used to provide rules for a slot. We also see
+;;; the initarg :len used to override the default initform.
+;;;
+;;; By extending defclass we (a) retain its expressiveness, and (b) produce
+;;; something hopefully easier to learn by developers already familiar with CLOS.
+;;;
+;;; The first extension we see is that the len initform refers to the
+;;; Smalltalk-like anaphoric variable self, to which will be bound 
+;;; the rectangle instance being initialized. Normally an initform is evaluated 
+;;; without being able to see the instance, and any initialization requiring
+;;; that must be done in the class initializer.
+
+

tutorial/01a-dataflow.lisp

@@ -0,0 +1,17 @@
+(defpackage #:tu-dataflow (:use :cl :cells))
+(in-package #:tu-dataflow)
+
+(defmodel rectangle ()
+  ((len :initarg :len :accessor len
+     :initform (c? (* 2 (width self))))
+   (width :initarg :width :initform nil :accessor width))
+  (:default-initargs
+      :width (c? (/ (len self) 2))))
+
+#+test
+(let ((r (make-instance 'rectangle :len (c-in 42))))
+  (cells::ct-assert (eql 21 (width r)))
+  (cells::ct-assert (= 1000 (setf (len r) 1000))) ;; make sure we did not break SETF, which must return the value set
+  (cells::ct-assert (eql 500 (width r)))) ;; make sure new value propagated
+
+

tutorial/01b-change-handling.lisp

@@ -0,0 +1,36 @@
+#| There is the fun part: automatic state management. Not only can a slot get its value from
+a self-aware rule, but that value will stay current with other values as they change.
+
+But often changes to a value must be reflected outside the automatic dataflow model. See next.
+
+|#
+
+(defpackage #:tu-change-handling (:use :cl :cells))
+(in-package #:tu-change-handling)
+
+(defmodel rectangle ()
+  ((len :initarg :len :accessor len
+     :initform (c? (* 2 (width self))))
+   (width :initarg :width :initform nil :accessor width))
+  (:default-initargs
+      :width (c? (/ (len self) 2))))
+
+(defvar *gui-told*)
+
+(defobserver len ((self rectangle) new-value old-value old-value-bound-p)
+  ;; Where rectangle is a GUI element, we need to tell the GUI framework
+  ;; to update this area of the screen
+  (setf *gui-told* t)
+  (print (list "tell GUI about" self new-value old-value old-value-bound-p)))
+
+#+test
+(let* ((*gui-told* nil)
+       (r (make-instance 'rectangle :len (c-in 42))))
+  (cells::ct-assert *gui-told*)
+  (setf *gui-told* nil)
+  (cells::ct-assert (eql 21 (width r)))
+
+  (cells::ct-assert (= 1000 (setf (len r) 1000)))
+  (cells::ct-assert *gui-told*)
+  (cells::ct-assert (eql 500 (width r))))
+

tutorial/01c-cascade.lisp

@@ -0,0 +1,31 @@
+#| Now we have automatic state management (including change propagation)
+outside the Cells model as well as in. Now lets look at cascading change
+by adding another level of computation, so A->B->C.
+
+[Actually, I see I need to make this a little deeper, since area has
+a direct dependency on width. Not tonight. :)]
+
+|#
+
+(defpackage #:tu-depth (:use :cl :cells))
+(in-package #:tu-depth)
+
+
+(defmodel rectangle ()
+  ((area :initarg :area :accessor area
+     :initform (c? (print :compue-area)
+                 (* (len self)(width self))))
+   (len :initarg :len :accessor len
+     :initform (c? (print :compute-len)
+                 (* 2 (width self))))
+   (width :initarg :width :accessor width
+     :initform (c? (print :compute-width)
+                 (floor (len self) 2)))))
+
+#+test
+(let ((r (make-instance 'rectangle :len (c-in 42))))
+  (cells::ct-assert (eql 21 (width r)))
+  (cells::ct-assert (eql (* 21 42) (area r)))
+  (cells::ct-assert (= 1000 (setf (len r) 1000)))
+  (cells::ct-assert (eql 500000 (area r))))
+

tutorial/02-lesson.lisp

@@ -0,0 +1,63 @@
+#|  A->B->C works. For efficiency, let's have propagation stop if some rule
+computes the same value as last time.
+|#
+
+(defpackage #:tu-smart-propagation (:use :cl :cells :utils-kt :tu-cells))
+(in-package #:tu-smart-propagation)
+
+
+;;; -----------------------------------------------
+
+(defmodel rectangle ()
+  ((padded-width :initarg :padded-width :accessor padded-width
+     :initform (c? (compute-log :padded-width)
+                 (+ 10 (width self))))
+   (len :initarg :len :accessor len
+     :initform (c? (compute-log :len)
+                 (* 2 (width self))))
+   (width :initarg :width :accessor width
+     :initform (c? (compute-log :width)
+                 (floor (len self) 2)))))
+
+(defobserver width ()
+  (assert (not (eql new-value old-value)))
+  (TRC "observing width" new-value old-value)
+  (compute-log :width-observer))
+
+(defobserver len ()
+  (compute-log :len-observer))
+
+#+test
+(let* ((r (progn
+            (CELLS-RESET)
+            (clear-computed)
+            (make-instance 'rectangle :len (c-in 42)))))
+  (cells::ct-assert (eql 21 (width r)))
+
+  ;; first check that setting an input cell does not
+  ;; propagate needlessly...
+
+  (clear-computed)
+  (verify-not-computed :len-observer :width :width-observer :padded-width)
+  (setf (len r) 42) ;; n.b. same as existing value, no change
+  (cells::ct-assert (eql 21 (width r))) ;; floor truncates
+  (verify-not-computed :len-observer :width :width-observer :padded-width)
+
+  ;; now check that intermediate computations, when unchanged
+  ;; from the preceding computation, does not propagate needlessly...
+
+  (clear-computed)
+  (setf (len r) 43)
+  (cells::ct-assert (eql 21 (width r))) ;; floor truncates
+  (verify-computed :len-observer :width)
+  (verify-not-computed :width-observer :padded-width)
+
+  #| Ok, so the engine runs the width rule, sees that it computes
+the same value as before, so does not invoke either the width
+observer or recalculation of are. Very efficient. The sanity check
+reconfirms that the engine does do that work when necessary.
+|# 
+
+  (clear-computed)
+  (setf (len r) 44)
+  (verify-computed :len-observer :width :width-observer :padded-width))

tutorial/03-ephemeral.lisp

@@ -0,0 +1,85 @@
+
+
+(defpackage #:tu-ephemeral (:use :cl :utils-kt :cells :tu-cells))
+(in-package #:tu-ephemeral)
+
+
+#|
+
+Events present a problem for spreadsheet models. Suppose we have a clicked rule for a button
+which says:
+
+     :clicked (c? (point-in-rect
+                   (screen-location (mouse-event *window*))
+                   (bounding-box self)))
+
+Now suppose we get a mouse-event outside the bounding box of widget X, and then in the
+next application event something happens that makes the bounding box grow such that it
+includes the location of the old mouse event. We need the mouse-event not to be there any more, 
+because, well, events are events. It is relevant only in the moment of its creation and propagation.
+
+Note, btw, that this must happen not as bang-bang:
+
+   (setf (mouse-event *window*) (get-next-event) 
+   (setf (mouse-event *window*) nil)
+
+...because observers can kick off state change, and anyway SETF has interesting Cell semantics,
+including observers firing. So setf-nil is a kludge, better that the Cells engine acknowledge that
+events are different and accomodate them by silently reverting an event to nil as soon as it finishes
+propagating.
+
+Finally, so far this has worked out well as a slot attribute as defined at the class level, not 
+instance by instance, by specifying :cell :ephemeral
+
+|#
+
+(defmodel rectangle ()
+  ((click :cell :ephemeral :initform (c-in nil) :accessor click)
+   (bbox :initarg :bbox :initform (c-in nil) :accessor bbox)
+   (clicked :cell :ephemeral :accessor clicked
+     :initform (c? (point-in-rect (^click)(^bbox))))))
+
+(defun point-in-rect (p r)
+  (when (and p r)
+    (destructuring-bind (x y) p
+        (destructuring-bind (l top r b) r
+          (and (<= l x r)
+            (<= b y top))))))
+
+(defobserver click ((self rectangle) new-value old-value old-value-bound-p)
+  (when new-value
+    (with-integrity (:change)
+      (TRC "setting bbox!!!")
+      (setf (bbox self) (list -1000 1000 1000 -1000)))))
+
+(defobserver clicked ((self rectangle) new-value old-value old-value-bound-p)
+  (when new-value
+    (TRC "clicked!!!!" self new-value)
+    (compute-log :clicked)))
+
+#+test
+(progn
+  (cells-reset)
+  (let* ((starting-bbox (list 10 10 20 20))
+         (r (make-instance 'rectangle 
+              :bbox (c-in (list 10 10 20 20)))))
+    (clear-computed)
+    (setf (click r) (list 0 0))
+    (assert (and (not (point-in-rect (list 0 0) starting-bbox))
+              (point-in-rect (list 0 0)(bbox r))
+              (verify-not-computed :clicked)))))
+
+#|
+The assertion demonstrates... well, it is complicated. Point 0-0 is
+in the current bbox, but the system correctly determines that it
+was not clicked. The click event at 0-0 happened when the bbox
+was elsewhwer. When the bbox moved, the Cells engine had already cleared
+the "ephemeral" click.
+
+Note that now we have less transparency: if one wants to perturb the data model
+from with an observer of some ongoing perturbation, one needs to arrange for
+that nested perturbation to wait until the ongoing one completes. That
+explains the "with-integrity" macro.
+
+|#
+