From ktilton at common-lisp.net  Sat Jun  3 00:38:05 2006
From: ktilton at common-lisp.net (ktilton)
Date: Fri,  2 Jun 2006 20:38:05 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060603003805.18921710E7@common-lisp.net>

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

Modified Files:
	cells.lisp 
Log Message:
-(defparameter *client-queue-handler* NIL)
 +(defparameter *client-queue-handler* nil)

--- /project/cells/cvsroot/cells/cells.lisp	2006/05/30 02:47:45	1.10
+++ /project/cells/cvsroot/cells/cells.lisp	2006/06/03 00:38:04	1.11
@@ -31,7 +31,7 @@
 (defparameter *c-debug* nil)
 (defparameter *defer-changes* nil)
 (defparameter *within-integrity* nil)
-(defparameter *client-queue-handler* NIL)
+(defparameter *client-queue-handler* nil)
 (defparameter *unfinished-business* nil)
 (defun cells-reset (&optional client-queue-handler)
   (utils-kt-reset)



From ktilton at common-lisp.net  Sat Jun  3 12:04:37 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sat,  3 Jun 2006 08:04:37 -0400 (EDT)
Subject: [cells-cvs] CVS Celtk
Message-ID: <20060603120437.87DDA7700E@common-lisp.net>

Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv8641

Modified Files:
	Celtk.lisp canvas.lisp composites.lisp demos.lisp entry.lisp 
	fileevent.lisp run.lisp tk-events.lisp tk-interp.lisp 
	tk-object.lisp tk-structs.lisp togl.lisp widget.lisp 
Log Message:


--- /project/cells/cvsroot/Celtk/Celtk.lisp	2006/05/28 23:47:24	1.28
+++ /project/cells/cvsroot/Celtk/Celtk.lisp	2006/06/03 12:04:37	1.29
@@ -16,7 +16,7 @@
 
 |#
 
-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.28 2006/05/28 23:47:24 fgoenninger Exp $
+;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.29 2006/06/03 12:04:37 ktilton Exp $
 
 (defpackage :celtk
   (:nicknames "CTK")
@@ -125,8 +125,6 @@
     "]" "\\]")
    "\"" "\\\""))
 
-(tkescape "[exit]")
-
 (defun tk-format-now (fmt$ &rest fmt-args)
   (unless (find *tkw* *windows-destroyed*)
     (let* ((*print-circle* nil)
@@ -134,14 +132,15 @@
       ;
       ; --- debug stuff ---------------------------------
       ;
-;;       (let ((yes '( "insert" "end"))
-;;             (no  '()))
-;;         (declare (ignorable yes no))
-;;         (when (and (find-if (lambda (s) (search s tk$)) yes)
-;;                    (not (find-if (lambda (s) (search s tk$)) no)))
-;;           (format t "~&tk> ~a~%" tk$))
-;; 	  (break))
-;;       (assert *tki*)
+
+      (let ((yes '( "photo"))
+            (no  '()))
+        (declare (ignorable yes no))
+        (when (and (find-if (lambda (s) (search s tk$)) yes)
+                        (not (find-if (lambda (s) (search s tk$)) no)))
+          (format t "~&tk> ~a~%" tk$)))
+      (assert *tki*)
+
       ; --- end debug stuff ------------------------------
       ;
       ; --- serious stuff ---
--- /project/cells/cvsroot/Celtk/canvas.lisp	2006/05/24 20:38:54	1.7
+++ /project/cells/cvsroot/Celtk/canvas.lisp	2006/06/03 12:04:37	1.8
@@ -32,11 +32,7 @@
   (:default-initargs
       :xscrollcommand (c-in nil)
     :yscrollcommand (c-in nil)
-    :id (gentemp "CV")
-;;;    :virtual-event-handlers (c? (list
-;;;                                 (focusIn->active)
-;;;                                 (focusOut->active)))
-    ))
+    :id (gentemp "CV")))
 
 (defun focusIn->active ()
   (list '|<FocusIn>| (lambda (self event &rest args)
--- /project/cells/cvsroot/Celtk/composites.lisp	2006/05/24 20:38:54	1.9
+++ /project/cells/cvsroot/Celtk/composites.lisp	2006/06/03 12:04:37	1.10
@@ -72,17 +72,25 @@
 (eval-when (compile load eval)
   (export '(title$ active)))
 
+(defvar *app*)
+
+(defmodel application (family)
+  ((app-time :initform (c-in (get-internal-real-time))
+     :initarg :app-time
+     :accessor app-time)))
+
+(defmethod path ((self application)) nil)
+
+(defun app-idle (self)
+  (setf (^app-time) (now)))
+
 (defmodel window (composite-widget)
-  (#+wishful (wish :initarg :wish :accessor wish
-               :initform (wish-stream *wish*)
-               #+(or) (c? (do-execute "wish85 -name testwindow" 
-                            nil #+not (list (format nil "-name ~s" (title$ self))))))
-    #+wishful (ewish :initarg :ewish :accessor ewish :initform nil :cell nil) ;; vestigial?
-    (title$ :initarg :title$ :accessor title$
+  ((title$ :initarg :title$ :accessor title$
       :initform (c? (string-capitalize (class-name (class-of self)))))
     (dictionary :initarg :dictionary :initform (make-hash-table :test 'equalp) :accessor dictionary)
     (tkwins :initform (make-hash-table) :reader tkwins)
     (xwins :initform (make-hash-table) :reader xwins)
+    (keyboard-modifiers :initarg :keyboard-modifiers :initform (c-in nil) :accessor keyboard-modifiers)
     (callbacks :initarg :callbacks :accessor callbacks
       :initform (make-hash-table :test #'eq))
     (edit-style :initarg :edit-style :accessor edit-style :initform (c-in nil))
@@ -92,8 +100,7 @@
     (tkfont-sizes-to-load :initarg :tkfont-sizes-to-load :accessor tkfont-sizes-to-load :initform nil)
     (tkfont-info :initarg :tkfont-info :accessor tkfont-info
       :initform (tkfont-info-loader))
-    (initial-focus :initarg :initial-focus :accessor initial-focus :initform nil))
-  )
+    (initial-focus :initarg :initial-focus :accessor initial-focus :initform nil)))
 
 (defobserver initial-focus ()
   (when new-value
--- /project/cells/cvsroot/Celtk/demos.lisp	2006/05/28 15:34:27	1.20
+++ /project/cells/cvsroot/Celtk/demos.lisp	2006/06/03 12:04:37	1.21
@@ -20,14 +20,23 @@
 
 (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package
   (test-window 
-   'one-button-window
+   ;;'place-test
+   ;;'one-button-window
    ;;'ltktest-cells-inside
    ;;'menu-button-test
    ;;'spinbox-test
-  ;;'lotsa-widgets
+   'lotsa-widgets
    ;; Now in Gears project 'gears-demo
   ))
 
+(defmodel place-test (window)
+  ()
+  (:default-initargs
+      :kids (c? (the-kids                
+                 (mk-label :text "hi, Mom"
+                   :x 100
+                   :y 20)))))
+
 (defmodel one-button-window (window)
   ()
   (:default-initargs
--- /project/cells/cvsroot/Celtk/entry.lisp	2006/05/31 05:08:25	1.13
+++ /project/cells/cvsroot/Celtk/entry.lisp	2006/06/03 12:04:37	1.14
@@ -16,7 +16,7 @@
 
 |#
 
-;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.13 2006/05/31 05:08:25 fgoenninger Exp $
+;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.14 2006/06/03 12:04:37 ktilton Exp $
 
 (in-package :Celtk)
 
@@ -108,28 +108,8 @@
   (with-integrity (:client `(:variable ,self))
     (tk-format-now "~a delete 1.0 end" (^path))
     (when (plusp (length new-value))
-      (trc "*** md-value text widget: new-value" new-value)
       (tk-format-now "~a insert end {~a}" (^path) new-value)) ;; kt060528: simple {} seems to block evaluation
     ;; Yes, it does. But we had to change ~s to ~a also in order to prevent
     ;; side effects - frgo 2006-05-29 1:30 am ;-)
     (tk-format-now "update idletasks"))) ;; Causes a display update after each text widget operation.
 
-;; The beginnings of a new text widget api:
-;; (defmethod insert ((self text-widget) &rest args)
-;;   (tk-format-now ))
-
-;;;(defvar +tk-keysym-table+
-;;;  (let ((ht (make-hash-table :test 'string=)))
-;;;    (with-open-file (ksyms "/0dev/math-paper/tk-keysym.dat" :direction :input)
-;;;      (loop for ksym-def = (read-line ksyms nil nil)
-;;;          for end = (position #\space ksym-def)
-;;;          while end
-;;;          do (let ((ksym (subseq ksym-def 0 end)))
-;;;               (setf (gethash ksym ht) (read-from-string ksym-def nil nil :start (1+ end))))
-;;;          finally (return ht)))))
-
- (defun tk-translate-keysym (keysym$)
-   (if (= 1 (length keysym$))
-      (schar keysym$ 0)
-    (intern (string-upcase keysym$))
-    #+nah (gethash keysym$ +tk-keysym-table+)))
\ No newline at end of file
--- /project/cells/cvsroot/Celtk/fileevent.lisp	2006/05/31 05:09:14	1.6
+++ /project/cells/cvsroot/Celtk/fileevent.lisp	2006/06/03 12:04:37	1.7
@@ -21,7 +21,7 @@
 ;;; DEALINGS IN THE SOFTWARE.
 ;;;
 ;;; ---------------------------------------------------------------------------
-;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.6 2006/05/31 05:09:14 fgoenninger Exp $
+;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.7 2006/06/03 12:04:37 ktilton Exp $
 ;;; ---------------------------------------------------------------------------
 
 ;;; ===========================================================================
@@ -157,32 +157,24 @@
 ;;; update operation.
 
 (defun file-event-opcode-cell-rule ()
-  (c? ;; Set the opcode depending on values of input-fd, output-fd, iostream,
-      ;; readable-cb, writeable-cb
-
-      (if (and (not (^input-fd))
-	       (not (^output-fd))
-	       (not .cache))
-        :nop
+  "Set the opcode depending on values of input-fd, output-fd, iostream, readable-cb, writeable-cb"
+  (c? (cond
+       ((not (or (^input-fd) (^output-fd) .cache))
+        :nop)
        
-        (if (and (^input-fd)
-		 (^iostream)
-	         (^readable-cb))
-	   :update-input-tk-fileevent
+       ((and (^input-fd) (^iostream) (^readable-cb))
+        :update-input-tk-fileevent)
 	   
-	   (if (and (^output-fd)
-		    (^iostream)
-		    (^writeable-cb))
-	       :update-output-tk-fileevent
-	       
-	      (if (and (not (^iostream))
-		       (not (^input-fd)))
-		 :reset-input-tk-fileevent
+       ((and (^output-fd) (^iostream) (^writeable-cb))
+        :update-output-tk-fileevent)
+       
+       ((not (or (^iostream) (^input-fd)))
+        :reset-input-tk-fileevent)
 		 
-		 (if (and (not (^iostream))
-			  (not (^output-fd)))
-		     :reset-output-tk-fileevent
-		     :nop)))))))
+       ((not (or (^iostream) (^output-fd)))
+        :reset-output-tk-fileevent)
+
+       (t :nop))))
 
 ;;; ===========================================================================
 ;;; INIT-TK-FILEEVENT - CALLED UPON INITIALIZATION
@@ -347,7 +339,7 @@
 
 (defobserver readable-cb ((self tk-fileevent))
   (if new-value
-    (Tcl_CreateCommand *tki*
+    (tcl-create-command *tki*
 		       "readable-cb"
 		       new-value
 		       (null-pointer)
@@ -355,7 +347,7 @@
 
 (defobserver writeable-cb ((self tk-fileevent))
   (if new-value
-    (Tcl_CreateCommand *tki*
+    (tcl-create-command *tki*
 		       "writeable-cb"
 		       new-value
 		       (null-pointer)
@@ -363,7 +355,7 @@
 
 (defobserver eof-cb ((self tk-fileevent))
   (if new-value
-    (Tcl_CreateCommand *tki*
+    (tcl-create-command *tki*
 		       "eof-cb"
 		       new-value
 		       (null-pointer)
--- /project/cells/cvsroot/Celtk/run.lisp	2006/05/26 17:50:36	1.14
+++ /project/cells/cvsroot/Celtk/run.lisp	2006/06/03 12:04:37	1.15
@@ -18,7 +18,7 @@
 
 (in-package :Celtk)
 
-;;; --- running a Celtk application (window class, actually) --------------------------------------
+;;; --- running a Celtk (window class, actually) --------------------------------------
 
 (eval-when (compile load eval)
   (export '(tk-scaling run-window test-window)))
@@ -35,15 +35,24 @@
   (tk-togl-init *tki*)
   (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <<trace>> -data $op}")
   (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) (null-pointer) (null-pointer))
-  
-  (with-integrity ()
-    (setf *tkw* (make-instance root-class))
+  (tcl-create-command *tki* "do-key-down" (get-callback 'do-on-key-down) (null-pointer) (null-pointer))
+  (tcl-create-command *tki* "do-key-up" (get-callback 'do-on-key-up) (null-pointer) (null-pointer))
+
+  (with-integrity () ;; w/i somehow ensures tkwin slot gets populated
+    (setf *app*
+      (make-instance 'application
+        :kids (c? (the-kids
+                   (setf *tkw* (make-instance root-class
+                                 :fm-parent *parent*)))))))
+
+  (assert (tkwin *tkw*))
 
-  (tk-create-event-handler-ex *tkw* 'main-window-proc -1 :structureNotifyMask :virtualEventMask))
+  (tk-create-event-handler-ex *tkw* 'main-window-proc -1)
   
   (tk-format `(:fini) "wm deiconify .")
   (tk-format-now "bind . <Escape> {destroy .}")
-
+  (tk-format-now "bind . <KeyPress> {do-key-down %W %K}")
+  (tk-format-now "bind . <KeyRelease> {do-key-up %W %K}")
   (tcl-do-one-event-loop))
 
 (defun ensure-destruction (w)
@@ -53,32 +62,58 @@
     (let ((*windows-being-destroyed* (cons w *windows-being-destroyed*)))
       (not-to-be w))))
 
-(defcallback main-window-proc :void  ((client-data :pointer)(xe :pointer))
-  (declare (ignore client-data))
-  (TRC nil "main window event" (xevent-type xe))
-  (case (xevent-type xe)
-    (:destroyNotify
-     (let ((*windows-destroyed* (cons *tkw* *windows-destroyed*)))
-       (ensure-destruction *tkw*)))
-    (:virtualevent
-     (bwhen (n$ (xsv name xe))
-       (trc nil "main-window-proc :" n$ (unless (null-pointer-p (xsv user-data xe))
-                                      (tcl-get-string (xsv user-data xe))))
-       (case (read-from-string (string-upcase n$))
-
-         (close-window
-          (ensure-destruction *tkw*))
-
-         (window-destroyed
-          (ensure-destruction *tkw*))
-
-         (time-is-up
-          (let ((self (gethash (tcl-get-string (xsv user-data xe)) (dictionary *tkw*))))
-            (bwhen (c (^on-command))
-              (funcall c self))))
+(defparameter *keyboard-modifiers*
+  (loop with km = (make-hash-table :test 'equalp)
+      for (keysym mod) in '(("Shift_L" :shift)
+                          ("Shift_R" :shift)
+                          ("Alt_L" :alt)
+                          ("Alt_R" :alt)
+                          ("Control_L" :control)
+                          ("Control_R" :control))
+      do (setf (gethash keysym km) mod)
+      finally (return km)))
 
-         (otherwise (trc "main window sees unknown" n$))))))
-  0)
+(defun keysym-to-modifier (keysym)
+  (gethash keysym *keyboard-modifiers*))
+
+(defcallback main-window-proc :void  ((client-data :pointer)(xe :pointer))
+  (let ((*tkw* (tkwin-widget client-data)))
+    (assert (typep *tkw* 'window))
+    (TRC nil "main window event" (xevent-type xe))
+    (flet ((give-to-window ()
+             (bwhen (eh (event-handler *tkw*))
+               (funcall eh *tkw* xe))))
+      (case (xevent-type xe)
+        ((:MotionNotify :buttonpress)
+         #+shhh (call-dump-event client-data xe))
+        (:destroyNotify
+         (let ((*windows-destroyed* (cons *tkw* *windows-destroyed*)))
+           (ensure-destruction *tkw*)))
+        (:virtualevent
+         (bwhen (n$ (xsv name xe))
+           (trc nil "main-window-proc :" n$ (unless (null-pointer-p (xsv user-data xe))
+                                              (tcl-get-string (xsv user-data xe))))
+           (case (read-from-string (string-upcase n$))
+             (keypress (let ((keysym (tcl-get-string (xsv user-data xe))))
+                         (bIf (mod (keysym-to-modifier keysym))
+                           (eko ("modifiers now")
+                             (pushnew mod (keyboard-modifiers *tkw*)))
+                           (trc "unhandled pressed keysym" keysym))))
+             (keyrelease (let ((keysym (tcl-get-string (xsv user-data xe))))
+                           (bIf (mod (keysym-to-modifier keysym))
+                             (eko ("modifiers now")
+                               (setf (keyboard-modifiers *tkw*)
+                                 (delete mod (keyboard-modifiers *tkw*))))
+                             (trc "unhandled released keysym" keysym))))
+             (close-window
+              (ensure-destruction *tkw*))
+           
+             (window-destroyed
+              (ensure-destruction *tkw*))
+             
+             (otherwise (give-to-window)))))
+        (otherwise (give-to-window)))
+      0)))
 
 ;; Our own event loop ! - Use this if it is desirable to do something
 ;; else between events
@@ -86,16 +121,17 @@
 (defparameter *event-loop-delay* 0.08 "Minimum delay [s] in event loop not to lock out IDE (ACL anyway)")
 
 (defun tcl-do-one-event-loop ()
-  (loop while (progn (trc nil "checking num main windows")
-                (plusp (tk-get-num-main-windows)))
-      do (trc nil "calling Tcl_DoOneEvent" (tk-get-num-main-windows))
-        (loop until (zerop (Tcl_DoOneEvent 2))) ;; 2== TCL_DONT_WAIT
-        (trc nil "sleeping")
+  (loop while (plusp (tk-get-num-main-windows))
+      do (loop until (zerop (Tcl_DoOneEvent 2))
+             do (app-idle *app*)) ;; 2== TCL_DONT_WAIT
+        (app-idle *app*)
         (sleep *event-loop-delay*) ;; give the IDE a few cycles
       finally
         (trc nil "Tcl-do-one-event-loop sees no more windows" *tki*)
         (tcl-delete-interp *tki*) ;; probably unnecessary
-        (setf *tki* nil)))
+        (setf *app* nil *tkw* nil *tki* nil)))
+
+(defmethod window-idle ((self window)))
 
 (defun test-window (root-class)
   "nails existing window as a convenience in iterative development"
@@ -109,3 +145,47 @@
     (setf *tkw* nil))
 
   (run-window root-class))
+
+;;; --- commands -----------------------------------------------------------------
+
+(defmacro defcommand (name)
+  (let ((do-on-name (read-from-string (format nil "DO-ON-~a" name)))
+        (^on-name (read-from-string (format nil "^ON-~a" name))))
+    `(progn
+       (defmethod ,do-on-name (self &rest args)
+         (bIf (cmd (,^on-name))
+           (apply cmd self args)
+           (format t "~&Warning: Target widget ~a has no ~a to run" self ',do-on-name))
+         0)
+
+       (defcallback ,do-on-name :int ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer))
+         (declare (ignore client-data))
+         (let ((*tki* interp)
+               (args (loop for argn upfrom 1 below argc
+                         collecting (mem-aref argv :string argn))))
+           (bif (self (gethash (car args) (dictionary *tkw*)))
+             (apply ',do-on-name self (rest args))
+             (progn
+               (break ",do-on-name> Target widget ~a does not exist" (car args))
+               #+anyvalue? (tcl-set-result interp
+                             (format nil ",do-on-name> Target widget ~a does not exist" (car args))
+                             (null-pointer))
+               1)))))))
+
+(defcommand command)
+(defcommand key-up)
+(defcommand key-down)
+
+;;;(defcallback do-on-command :int ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer))
+;;;  (declare (ignore client-data))
+;;;  (let ((*tki* interp)
+;;;        (args (loop for argn upfrom 1 below argc
+;;;            collecting (mem-aref argv :string argn))))
+;;;    (bif (self (gethash (car args) (dictionary *tkw*)))
+;;;        (apply 'do-on-command self (rest args))
+;;;        (progn
+;;;          (break "do-on-command> Target widget ~a does not exist" path)
+;;;          #+anyvalue? (tcl-set-result interp
+;;;            (format nil "do-on-command> Target widget ~a does not exist" path)
+;;;            (null-pointer))
+;;;          1)))))
\ No newline at end of file
--- /project/cells/cvsroot/Celtk/tk-events.lisp	2006/05/24 20:38:54	1.4
+++ /project/cells/cvsroot/Celtk/tk-events.lisp	2006/06/03 12:04:37	1.5
@@ -27,13 +27,6 @@
   (tcl-idle-proc :pointer)
   (client-data :pointer))
 
-(defcfun ("Tcl_CreateCommand" tcl-create-command) :pointer
-  (interp :pointer)
-  (cmdName :string)
-  (proc :pointer)
-  (client-data :pointer)
-  (delete-proc :pointer))
-
 (defcfun ("Tcl_SetResult" tcl-set-result) :void
   (interp :pointer)
   (result :string)
@@ -133,8 +126,6 @@
   (ignore-errors 
    (foreign-enum-keyword 'tk-event-type n)))
 
-
-
 (defun tk-event-mask-symbol (n) ;; do not try to generate masks from these!
   (ignore-errors 
    (foreign-enum-keyword 'tk-event-mask n)))
@@ -160,6 +151,8 @@
 
   (trc "tkep> " (tk-event-type (mem-aref xe :int)) :client-data client-data)
   (case (tk-event-type (mem-aref xe :int))
+    (:motionnotify
+     (trc nil "motionnotify" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe)))
     (:virtualevent
      (trc "    > :type" (format nil "<<~a>>" (xsv name xe)) :time (xsv time xe) :state (xsv state xe))
      (trc "    > :x" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe))
@@ -171,4 +164,21 @@
      (trc "    > data" (unless (null-pointer-p (xsv user-data xe))
                          (tcl-get-string (xsv user-data xe)))))))
 
+(defun xevent-dump (xe)
+  (case (tk-event-type (mem-aref xe :int))
+    (:motionnotify
+     (trc nil "motionnotify" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe)))
+    (:virtualevent
+     (trc "    > :type" (format nil "<<~a>>" (xsv name xe)) :time (xsv time xe) :state (xsv state xe))
+     (trc "    > :x" (xsv x xe) :y (xsv y xe) :x-root (xsv x-root xe) :y-root (xsv y-root xe))
+     (trc "    > event/root/sub" (mapcar (lambda (w) (when w (path w)))
+                                (list (xwin-widget (xsv event-window xe))
+                                  (xwin-widget (xsv root-window xe))
+                                  (xwin-widget (xsv sub-window xe)))))
+
+     (trc "    > data" (unless (null-pointer-p (xsv user-data xe))
+                         (tcl-get-string (xsv user-data xe)))))
+    (otherwise
+     (trc "tkep> " (tk-event-type (mem-aref xe :int))))))
+
 
--- /project/cells/cvsroot/Celtk/tk-interp.lisp	2006/05/31 05:10:30	1.13
+++ /project/cells/cvsroot/Celtk/tk-interp.lisp	2006/06/03 12:04:37	1.14
@@ -136,12 +136,12 @@
 ;; Tcl_CreateCommand - used to implement direct callbacks
 ;; ----------------------------------------------------------------------------
 
-(defcfun ("Tcl_CreateCommand" Tcl_CreateCommand) :pointer
+(defcfun ("Tcl_CreateCommand" tcl-create-command) :pointer
   (interp :pointer)
   (cmdName :string)
-  (cmdProc :pointer)
-  (clientData :int)
-  (deleteProc :pointer))
+  (proc :pointer)
+  (client-data :pointer)
+  (delete-proc :pointer))
 
 ;; ----------------------------------------------------------------------------
 ;; Tcl/Tk channel related stuff
--- /project/cells/cvsroot/Celtk/tk-object.lisp	2006/05/24 20:38:54	1.4
+++ /project/cells/cvsroot/Celtk/tk-object.lisp	2006/06/03 12:04:37	1.5
@@ -27,6 +27,8 @@
    
    (timers :initarg :timers :accessor timers :initform nil)
    (on-command :initarg :on-command :accessor on-command :initform nil)
+   (on-key-down :initarg :on-key-down :accessor on-key-down :initform nil)
+   (on-key-up :initarg :on-key-up :accessor on-key-up :initform nil)
    (user-errors :initarg :user-errors :accessor user-errors :initform nil))
   (:documentation "Root class for widgets and (canvas) items"))
 
--- /project/cells/cvsroot/Celtk/tk-structs.lisp	2006/05/31 05:11:28	1.4
+++ /project/cells/cvsroot/Celtk/tk-structs.lisp	2006/06/03 12:04:37	1.5
@@ -98,7 +98,7 @@
 |#
 
 (defcstruct x-virtual-event
-    "Virtual event, OK?"
+    "common event fields"
   (type :int)
   (serial :unsigned-long)
   (send-event :boolean)
@@ -120,9 +120,48 @@
 (defmacro xsv (slot-name xptr)
   `(foreign-slot-value ,xptr 'X-Virtual-Event ',slot-name))
 
+(defmacro xke (slot-name xptr)
+  `(foreign-slot-value ,xptr 'x-key-event ',slot-name))
+
 (defun xevent-type (xe)
   (tk-event-type (xsv type xe)))
 
+;; -------------------------------------------
+
+(defcstruct x-key-event
+   "X key Event"
+  (xke-header x-virtual-event)
+  (trans-char-0 :char)
+  (trans-char-1 :char)
+  (trans-char-2 :char)
+  (trans-char-3 :char))
+
+(defcstruct x-button-event
+    "common event fields"
+  (type :int)
+  (serial :unsigned-long)
+  (send-event :boolean)
+  (display :pointer)
+  (event-window Window)
+  (root-window Window)
+  (sub-window Window)
+  (time Time)
+  (x :int)
+  (y :int)
+  (x-root :int)
+  (y-root :int)
+  (state :unsigned-int)
+  (button :unsigned-int)
+  (same-screen :boolean))
+
+(defmacro xbe (slot-name xptr)
+  `(foreign-slot-value ,xptr 'x-button-event ',slot-name))
+
+(defun xbe-x (xbe) (xbe x xbe))
+(defun xbe-y (xbe) (xbe y xbe))
+
+;; --------------------------------------------
+
 (defcenum tcl-event-flag-values
     (:tcl-dont-wait         2)
   (:tcl-window-events     4)
--- /project/cells/cvsroot/Celtk/togl.lisp	2006/05/27 06:04:22	1.8
+++ /project/cells/cvsroot/Celtk/togl.lisp	2006/06/03 12:04:37	1.9
@@ -28,40 +28,25 @@
 
 ;;; --- Togl (Version 1.7 and above needed!) -----------------------------
 
-(defcfun ("Togl_Init" Togl_Init) tcl-retcode
+(defcfun ("Togl_Init" Togl-Init) tcl-retcode
   (interp :pointer))
 
-(defcfun ("Togl_CreateFunc" Togl_CreateFunc) :void
-  (togl-callback-ptr :pointer))
-
-(defcfun ("Togl_DisplayFunc" Togl_DisplayFunc) :void
-  (togl-callback-ptr :pointer))
-
-(defcfun ("Togl_ReshapeFunc" Togl_ReshapeFunc) :void
-  (togl-callback-ptr :pointer))
-
-(defcfun ("Togl_DestroyFunc" Togl_DestroyFunc) :void
-  (togl-callback-ptr :pointer))
-
-(defcfun ("Togl_TimerFunc" Togl_TimerFunc) :void
-  (togl-callback-ptr :pointer))
-
-(defcfun ("Togl_PostRedisplay" Togl_PostRedisplay) :void
+(defcfun ("Togl_PostRedisplay" togl-post-redisplay) :void
   (togl-struct-ptr :pointer))
 
-(defcfun ("Togl_SwapBuffers" Togl_SwapBuffers) :void
+(defcfun ("Togl_SwapBuffers" togl-swap-buffers) :void
   (togl-struct-ptr :pointer))
 
 (defcfun ("Togl_Ident" Togl-Ident) :string
   (togl-struct-ptr :pointer))
 
-(defcfun ("Togl_Width" Togl_Width) :int
+(defcfun ("Togl_Width" Togl-Width) :int
   (togl-struct-ptr :pointer))
 
-(defcfun ("Togl_Height" Togl_Height) :int
+(defcfun ("Togl_Height" Togl-Height) :int
   (togl-struct-ptr :pointer))
 
-(defcfun ("Togl_Interp" Togl_Interp) :pointer
+(defcfun ("Togl_Interp" Togl-Interp) :pointer
   (togl-struct-ptr :pointer))
 
 ;; Togl_AllocColor
@@ -86,9 +71,9 @@
 ;; Togl_DumpToEpsFile
 
 (eval-when (compile load eval)
-  (export '(togl_swapbuffers togl_postredisplay togl-ptr togl-reshape-func
-             togl togl-timer-using-class Togl_PostRedisplay togl-reshape-using-class
-             togl-display-using-class togl_width togl_height togl-create-using-class)))
+  (export '(togl-swap-buffers togl-post-redisplay togl-ptr togl-reshape-func
+             togl togl-timer-using-class togl-post-redisplay togl-reshape-using-class
+             togl-display-using-class togl-width togl-height togl-create-using-class)))
 
 ;; --- gotta call this bad boy during initialization, I guess any time after we have an interpreter
 ;;
@@ -96,7 +81,7 @@
 (defun tk-togl-init (interp)
   ;(assert (not (zerop (tcl-init-stubs interp "8.1" 0))))
   ;(assert (not (zerop (tk-init-stubs interp "8.1" 0))))
-  (togl_init interp)
+  (togl-init interp)
   (togl-create-func (callback togl-create))
   (togl-destroy-func (callback togl-destroy))
   (togl-display-func (callback togl-display))
@@ -115,15 +100,15 @@
     -width ;;		400	Width of widget in pixels.
     -height ;;		400	Height of widget in pixels.
     -ident	;;	""	A user identification string ignored by togl.
-		;;	This can be useful in your C callback functions
-		;;	to determine which Togl widget is the caller.
+    ;;	This can be useful in your C callback functions
+    ;;	to determine which Togl widget is the caller.
     -rgba	;;	true	If true, use RGB(A) mode
-		;;	If false, use Color Index mode
+    ;;	If false, use Color Index mode
     -redsize      ;;	1	Min bits per red component
     -greensize	;; 1	Min bits per green component
     -bluesize	;; 1	Min bits per blue component
     -double		;; false	If false, request a single buffered window
-			;; If true, request double buffered window
+    ;; If true, request double buffered window
     -depth		;; false	If true, request a depth buffer
     -depthsize	;; 1	Min bits of depth buffer
     -accum		;; false	If true, request an accumulation buffer
@@ -132,33 +117,35 @@
     -accumbluesize	;; 1	Min bits per accum blue component
     -accumalphasize	;; 1	Min bits per accum alpha component
     -alpha		;; false	If true and -rgba is true, request an alpha
-			;; channel
+    ;; channel
     -alphasize	;; 1	Min bits per alpha component
     -stencil	;; false	If true, request a stencil buffer
     -stencilsize	;; 1	Min number of stencil bits
     -auxbuffers	;; 0	Desired number of auxiliary buffers
     -privatecmap	;; false	Only applicable in color index mode.
-		 	;; If false, use a shared read-only colormap.
-			;; If true, use a private read/write colormap.
+    ;; If false, use a shared read-only colormap.
+    ;; If true, use a private read/write colormap.
     -overlay      ;; false   If true, request overlay planes.
     -stereo       ;; false   If true, request a stereo-capable window.
     (-timer-interval -time)  ;; 1       Specifies the interval, in milliseconds, for
-                  ;     calling the C timer callback function which
-                  ;    was registered with Togl_TimerFunc.
+    ;     calling the C timer callback function which
+    ;    was registered with Togl_TimerFunc.
     -sharelist    ;; ""      Name of an existing Togl widget with which to
-                  ;     share display lists.
-                  ;    NOT YET IMPLEMENTED FOR WINDOWS 95/NT.
+    ;     share display lists.
+    ;    NOT YET IMPLEMENTED FOR WINDOWS 95/NT.
     -sharecontext ;; ""      Name of an existing Togl widget with which to
-                  ;     share the OpenGL context.  NOTE:  most other
-                  ;    attributes such as double buffering, RGBA vs CI,
-                  ;   ancillary buffer specs, etc are then ignored.
-                  ;  NOT YET IMPLEMENTED FOR WINDOWS 95/NT.
+    ;     share the OpenGL context.  NOTE:  most other
+    ;    attributes such as double buffering, RGBA vs CI,
+    ;   ancillary buffer specs, etc are then ignored.
+    ;  NOT YET IMPLEMENTED FOR WINDOWS 95/NT.
     -indirect     ;; false   If present, request an indirect rendering context.
-                  ;     A direct rendering context is normally requested.
-                  ;    NOT SIGNIFICANT FOR WINDOWS 95/NT.
+    ;     A direct rendering context is normally requested.
+    ;    NOT SIGNIFICANT FOR WINDOWS 95/NT.
     )
   (:default-initargs
-      :id (gentemp "TOGL")
+      :double t
+    :rgba t
+    :id (gentemp "TOGL")
     :ident (c? (^path))))
 
 (defmacro def-togl-callback (root (&optional (ptr-var 'togl-ptr)(self-var 'self)) &body preamble)
--- /project/cells/cvsroot/Celtk/widget.lisp	2006/05/26 18:02:02	1.11
+++ /project/cells/cvsroot/Celtk/widget.lisp	2006/06/03 12:04:37	1.12
@@ -55,25 +55,21 @@
    (xwin :cell nil :accessor xwin :initform nil)
    (packing :reader packing :initarg :packing :initform nil)
    (gridding :reader gridding :initarg :gridding :initform nil)
+   (x :reader x :initarg :x :initform nil)
+   (y :reader y :initarg :y :initform nil)
+   (relx :reader relx :initarg :relx :initform nil)
+   (rely :reader rely :initarg :rely :initform nil)
    (enabled :reader enabled :initarg :enabled :initform t)
    (event-handler :reader event-handler :initarg :event-handler :initform nil)
    (menus :reader menus :initarg :menus :initform nil
      :documentation "An assoc of an arbitrary key and the associated CLOS menu instances (not their tk ids)")
    (image-files :reader image-files :initarg :image-files :initform nil)
    (selector :reader selector :initarg :selector
-     :initform (c? (upper self selector)))
-   (on-event :initform nil :initarg :on-event :accessor on-event))
+     :initform (c? (upper self selector))))
   (:default-initargs
       :id (gentemp "W")
     :event-handler nil #+debug (lambda (self xe)
-                     (TRC "widget-event-handler" self (tk-event-type (xsv type xe)) )
-                     )))
-
-(defobserver event-handler ()
-  (when new-value ;; \\\ work out how to unregister any old value
-    (with-integrity (:client `(:post-make-tk ,self))
-      (trc nil "creating event handler for" self)
-      (tk-create-event-handler-ex self 'widget-event-handler -1)))) ;; // make this -1 more efficient
+                                 (TRC "widget-event-handler" self (tk-event-type (xsv type xe))))))
 
 (defun tk-create-event-handler-ex (widget callback-name &rest masks)
   (let ((self-tkwin (widget-to-tkwin widget)))
@@ -84,41 +80,6 @@
       (get-callback callback-name)
       self-tkwin)))
 
-(defcallback widget-event-handler :void  ((client-data :pointer)(xe :pointer))
-  (let ((self (tkwin-widget client-data)))
-    (assert self () "widget-event-handler > no widget for tkwin ~a" client-data)
-    (bif (h (^event-handler))
-      (funcall h self xe)
-      (trc "widget-event-handler > warning: no handler in instance requesting event handling" self))))
-
-(defclass commander ()
-  ()
-  (:default-initargs
-      :command (c? (format nil "do-on-command ~a" (^path)))))
-
-(defcallback do-on-command :int ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer))
-  (declare (ignore client-data))
-  (destructuring-bind (path &rest args)
-      (loop for argn upfrom 1 below argc
-          collecting (mem-aref argv :string argn))
-    (bif (self (gethash path (dictionary *tkw*)))
-      (bIf (cmd (^on-command))
-        (progn (apply cmd self args)
-          0)
-        (progn (tcl-set-result interp
-                 (format nil "do-on-command> Target widget ~a has no on-command to run" path)
-                 (null-pointer))
-          1))
-      (progn
-        (loop for hk being the hash-keys of (dictionary *tkw*)
-              when (string-equal hk path)
-              do (trc "found string-equal match" path))
-        (break "do-on-command> Target widget ~a does not exist" path)
-        (tcl-set-result interp
-          (format nil "do-on-command> Target widget ~a does not exist" path)
-          (null-pointer))
-        1))))
-
 (defun widget-menu (self key)
   (or (find key (^menus) :key 'md-name)
     (break "The only menus I see are~{ ~a,~} not requested ~a" (mapcar 'md-name (^menus)) key)))
@@ -143,7 +104,36 @@
 
 (defmethod make-tk-instance :after ((self widget)) 
   (with-integrity (:client `(:post-make-tk ,self))
-      (tkwin-register self)))
+    (tkwin-register self)
+    (tk-create-event-handler-ex self 'widget-event-handler-callback -1)))
+
+;;;(defobserver relx ()
+;;;  (when new-value
+;;;    (tk-format `(:grid ,self)
+;;;      "place ~a ~a -relx ~a -rely ~a" (if old-value "configure" "")
+;;;      (^path) new-value (^rely))))
+
+(defobserver x ((self widget))
+  (when new-value
+    (tk-format `(:grid ,self)
+      "place ~a ~a -x ~a -y ~a" (if old-value "configure" "")
+      (^path) new-value (^y))))
+
+(defcallback widget-event-handler-callback :void  ((client-data :pointer)(xe :pointer))
+  (let ((self (tkwin-widget client-data)))
+    (assert self () "widget-event-handler > no widget for tkwin ~a" client-data)
+    (widget-event-handle self xe)))
+
+(defmethod widget-event-handle ((self widget) xe)
+  (bif (h (^event-handler))
+    (funcall h self xe)
+    #+shhh (case (xevent-type xe)
+      (:buttonpress
+       (trc "button pressed:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe)))
+      
+      (:buttonrelease (trc "button released:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe)))(:MotionNotify
+       (xevent-dump xe))
+      (:virtualevent))))
 
 (defmethod tk-configure ((self widget) option value)
   (tk-format `(:configure ,self ,option) "~a configure ~(~a~) ~a" (path self) option (tk-send-value value)))
@@ -154,6 +144,14 @@
     (tk-format `(:forget ,self) "pack forget ~a" (^path))
     (tk-format `(:destroy ,self) "destroy ~a" (^path))))
 
+;;; --- commander mix-in --------------------------------
+
+(defclass commander ()
+  ()
+  (:default-initargs
+      :command (c? (format nil "do-on-command ~a" (^path)))))
+
+
 ;;; --- items -----------------------------------------------------------------------
 
 (eval-when (compile load eval)
@@ -254,15 +252,15 @@
       (let ((v$ (if (stringp new-value) ;; just going slow on switching over to C API before changing tk-send-value
                     new-value
                     (tk-send-value new-value))))
-        (tcl-set-var *tki* (tk-variable self) v$ (var-flags :TCL_NAMESPACE_ONLY))))))
+        (tcl-set-var *tki* (tk-variable self) v$ (var-flags :tcl-namespace-only))))))
 
 
 ;;; --- images -------------------------------------------------------
 
 (defobserver image-files ()
   (loop for (name file-pathname) in (set-difference new-value old-value :key 'car) 
-      do (tk-format `(:pre-make-tk  ,self) "image create photo ~(~a.~a~) -file ~a"
-           (^path) name (tkescape (namestring file-pathname)))))
+      do (tk-format `(:pre-make-tk  ,self) "image create photo ~(~a.~a~) -file {~a}"
+           (^path) name (progn #+not tkescape (namestring file-pathname)))))
 
 
 ;;; --- menus ---------------------------------



From ktilton at common-lisp.net  Sat Jun  3 12:12:19 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sat,  3 Jun 2006 08:12:19 -0400 (EDT)
Subject: [cells-cvs] CVS Celtk
Message-ID: <20060603121219.45A5F33011@common-lisp.net>

Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv9393

Modified Files:
	CELTK.lpr fileevent.lisp 
Log Message:


--- /project/cells/cvsroot/Celtk/CELTK.lpr	2006/05/28 15:34:27	1.14
+++ /project/cells/cvsroot/Celtk/CELTK.lpr	2006/06/03 12:12:19	1.15
@@ -10,7 +10,6 @@
                  (make-instance 'module :name "tk-interp.lisp")
                  (make-instance 'module :name "tk-events.lisp")
                  (make-instance 'module :name "tk-object.lisp")
-                 (make-instance 'module :name "fileevent.lisp")
                  (make-instance 'module :name "widget.lisp")
                  (make-instance 'module :name "font.lisp")
                  (make-instance 'module :name "layout.lisp")
@@ -27,6 +26,7 @@
                  (make-instance 'module :name "item-shaped.lisp")
                  (make-instance 'module :name "composites.lisp")
                  (make-instance 'module :name "frame.lisp")
+                 (make-instance 'module :name "fileevent.lisp")
                  (make-instance 'module :name "togl.lisp")
                  (make-instance 'module :name "run.lisp")
                  (make-instance 'module :name "ltktest-ci.lisp")
--- /project/cells/cvsroot/Celtk/fileevent.lisp	2006/06/03 12:04:37	1.7
+++ /project/cells/cvsroot/Celtk/fileevent.lisp	2006/06/03 12:12:19	1.8
@@ -21,7 +21,7 @@
 ;;; DEALINGS IN THE SOFTWARE.
 ;;;
 ;;; ---------------------------------------------------------------------------
-;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.7 2006/06/03 12:04:37 ktilton Exp $
+;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.8 2006/06/03 12:12:19 ktilton Exp $
 ;;; ---------------------------------------------------------------------------
 
 ;;; ===========================================================================
@@ -363,7 +363,7 @@
 
 (defobserver error-cb ((self tk-fileevent))
   (if new-value
-    (Tcl_CreateCommand *tki*
+    (tcl-create-command *tki*
 		       "error-cb"
 		       new-value
 		       (null-pointer)



From ktilton at common-lisp.net  Sun Jun  4 13:17:37 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sun,  4 Jun 2006 09:17:37 -0400 (EDT)
Subject: [cells-cvs] CVS cells/gui-geometry
Message-ID: <20060604131737.E6BF53D003@common-lisp.net>

Update of /project/cells/cvsroot/cells/gui-geometry
In directory clnet:/tmp/cvs-serv13860/gui-geometry

Log Message:
Directory /project/cells/cvsroot/cells/gui-geometry added to the repository





From ktilton at common-lisp.net  Sun Jun  4 13:19:59 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sun,  4 Jun 2006 09:19:59 -0400 (EDT)
Subject: [cells-cvs] CVS cells/gui-geometry
Message-ID: <20060604131959.DD465431CD@common-lisp.net>

Update of /project/cells/cvsroot/cells/gui-geometry
In directory clnet:/tmp/cvs-serv13961/gui-geometry

Added Files:
	coordinate-xform.lisp defpackage.lisp geo-data-structures.lisp 
	geo-family.lisp geometer.lisp gui-geometry.lpr 
Log Message:
Mostly adding a general-purpose GUI geometry component that makes good use of the Family class and specifically the kid-slotting mechanism.


--- /project/cells/cvsroot/cells/gui-geometry/coordinate-xform.lisp	2006/06/04 13:19:59	NONE
+++ /project/cells/cvsroot/cells/gui-geometry/coordinate-xform.lisp	2006/06/04 13:19:59	1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
#|

Copyright (C) 2004 by Kenneth William Tilton

This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
 (http://opensource.franz.com/preamble.html), known as the LLGPL.

This library is distributed  WITHOUT ANY WARRANTY; without even 
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  

See the Lisp Lesser GNU Public License for more details.

|#

(in-package :gui-geometry)

(defconstant *reference-dpi* 1440)

(let (
      (logical-dpi 96) ;;1440) 
      ; This is cello's internal dots per inch.  This value is germane only if size references are unqualified by a function call.
      ; Size references should always be qualified, as in (:pts 6), except when specifying pen widths.
      ; (Pen widths may pose a special case -- we may need to match screen pens to print pens.)
      
      (scan-resolution 300)                  
      ; This is the desired scan resolution, and the assumed resolution of all scans.
      ; Hypothetically, a scanner not capable of scanning at 300 dpi could make a big hash of this scheme.
      ; Rather than even pretend to support multiple resolutions within a study, for now we'll enforce 300 across the board.
      ; Dependencies on this spec can be identified by searching on scan-resolution.
      
      (logical-screen-resolution 96)         
      ; This is the internal logical screen resolution, which does _not_ have to equal the current LOGPIXELSX (LOGPIXELSY) value
      ; reported by GetDeviceCaps.  The original thought was that we could use this to rescale _all_ drawing on the fly.  Now that
      ; idea is being superseded by targetRes, but this functions (1) as a tacit targetRes for the outer window and (2) as a magic
      ; number to complicate debugging [we need to root out a few references in .bmp drawing, I think].
      
      ;;(printer-resolution 600)      ; /// improve #'cs-printer-resolution to bypass this.
      
      ;;(emf-resolution 600)
      
      )
  
  (declare (ignorable logical-dpi scan-resolution logical-screen-resolution printer-resolution))
  
  ; Notice the somewhat nonstandard naming convention:
  ; #'uInches takes logical inches and returns logical units (DPI)
  ; so, for instance, if logical-dpi = 1440, then (uInches 0.5) = 720.
  (defun u-round (number &optional (divisor 1))
    (multiple-value-bind (quotient remainder)
        (round number divisor)
      (declare (ignorable remainder))
      ;(assert (zerop remainder))
      ;(assert (zerop (mod quotient 15))) ;96ths
      quotient))
  

  (defun udots (dots dpi)
    (u-round (* dots logical-dpi) dpi))   ;only the first value will be used.
  
  (defun uinches (logical-inches)
    (u-round (* logical-inches logical-dpi)))   ;only the first value will be used.
  
  (defun uin (logical-inches)
    (uinches logical-inches))
  
  (defun upoints (logical-points)
    (udots logical-points  72))
  
  (defun upts (logical-points)
    (upoints logical-points))
  
  (defun u96ths (logical-96ths)
    (udots logical-96ths 96))
  
  (defun u8ths (logical-8ths)
    (udots logical-8ths 8))
  
  (defun u16ths (logical-16ths)
    (udots logical-16ths 16))
  
  (defun u32nds (logical-32nds)
    (udots logical-32nds 32))
  
  (defun u120ths (logical-120ths)
    (udots logical-120ths 120))
  
  (defun cs-logical-dpi ()
    logical-dpi)
  
  (defsetf cs-logical-dpi cs-logical-dpi-setf)
  
  (defun cs-logical-dpi-setf (new-value)
    (setf logical-dpi new-value))
  
  (defun cs-scan-resolution ()
    scan-resolution)
  
  (defun cs-logical-screen-resolution ()
    logical-screen-resolution)
  
  )




(defmethod u-cvt ((nn number) (units (eql :96ths)) )
  (u96ths nn))

(defmethod u-cvt ((nn number) (units (eql :8ths)) )
  (u8ths nn))

(defmethod u-cvt ((nn number) (units (eql :16ths)) )
  (u16ths nn))

(defmethod u-cvt ((nn number) (units (eql :32nds)) )
  (u32nds nn))

(defmethod u-cvt ((nn number) (units (eql :inches)) )
  (uinches nn))

(defmethod u-cvt ((nn number) (units (eql :points)) )
  (upoints nn))

(defmethod u-cvt (other units)
  (declare (ignore units))
  other)

(defmethod u-cvt ((nns cons) units)
  (cons (u-cvt (car nns) units)
        (u-cvt (cdr nns) units)))

(defmacro u-cvt! (nn units)
  `(u-cvt ,nn ,units))

(defun uv2 (x y u-key) (apply #'mkv2 (u-cvt (list x y) u-key)))

;-----------------

(defun os-logical-screen-dpi ()
  (break "need (win:GetDeviceCaps (device-context (screen *cg-system*)) win:LOGPIXELSX))"))
   
#+no(defun browser-target-resolution ()
  (target-resolution (find-window :clinisys)))

; set to 96 because the code is trying to do rect-frames for the header before the window is init'ed.

(let ((current-target-resolution 96))  ;initialize when main window is created  
   
   (defun set-current-target-resolution (resolution)
     #+shh(trc "setting current-target-resolution to" resolution)
     (setf current-target-resolution resolution))
   
   (defun cs-current-target-resolution ()
     current-target-resolution)
   
   (defun cs-target-res ()
     current-target-resolution)
   
   (defmacro with-target-resolution ((new-resolution) &rest body)
     (let ((old-resolution (gensym))
           )
        `(let ((,old-resolution (cs-current-target-resolution))
               )
            (prog2
              (set-current-target-resolution ,new-resolution)
                (progn , at body)
              (set-current-target-resolution ,old-resolution)
            ))))
   )


;converts screen pixels to logical pixels given the current target resolution OR OPTIONAL OTHER RES
(defun scr2log (dots &optional (target-res (cs-target-res)))
  (round (* dots (cs-logical-dpi))
         target-res))

(defun log2scr (logv &optional (target-res (cs-target-res)))
  (floor-round (* logv target-res )
         (cs-logical-dpi)))

(defun cs-archos-dpi ()
  (cs-logical-dpi))

(defun floor-round (x &optional (divisor 1))
  (ceiling (- (/ x divisor) 1/2)))

;converts logical pixels to screen pixels given the current target resolution OR OPTIONAL OTHER RES
(defun logical-to-screen-vector (dots &optional target-res)
  (let ((convert-res (or target-res (cs-target-res))))  
    (floor-round (* dots convert-res) (cs-logical-dpi))))

(defun logical-to-screen-point (point &optional target-res)
  (mkv2
   (log2scr (v2-h point) target-res)
   (log2scr (v2-v point) target-res)))

(defun screen-to-logical-v2 (point &optional target-res)
  (mkv2
   (scr2log (v2-h point) target-res)
   (scr2log (v2-v point) target-res)))

(defun nr-screen-to-logical (logical-rect screen-rect &optional target-res)
  (nr-make logical-rect
   (scr2log (r-left screen-rect) target-res)
   (scr2log (r-top screen-rect) target-res)
   (scr2log (r-right screen-rect) target-res)
    (scr2log (r-bottom screen-rect) target-res)))

; logical-to-target is a more sensible name throughout

(defun logical-to-target-vector (dots &optional target-res)
  (log2scr dots target-res))
;--------------------------------------------------------------------------------------------

(defun r-logical-to-screen (logical-rect &optional target-res)
  (count-it :r-logical-to-screen)
  (nr-logical-to-screen (mkr 0 0 0 0) logical-rect target-res))

(defun nr-logical-to-screen (screen-rect logical-rect &optional target-res)
  (nr-make screen-rect
   (log2scr (r-left logical-rect) target-res)
   (log2scr (r-top logical-rect) target-res)
   (log2scr (r-right logical-rect) target-res)
    (log2scr (r-bottom logical-rect) target-res)))

;------------------------------------------------------------------------------------------------

;;;(defun set-scaling (window)
;;;  #+shh(trc "targetResolution" (targetRes window))
;;; 
;;;  (set-current-target-resolution (cs-logical-screen-resolution))          ;here and below, we'll probably make scalable
;;;  ;(set-current-target-resolution (cs-logical-dpi))
;;;  (let ((dc (device-context window))
;;;        (display-dpi (cs-logical-screen-resolution))                       ;... and use (targetRes window)
;;;        (logical-dpi (cs-logical-dpi)))
;;;     (os-SetMapMode dc win:MM_ISOTROPIC)
;;;     (os-SetWindowExtEx dc logical-dpi logical-dpi ct:hnull)                  
;;;     (os-SetViewportExtEx dc display-dpi display-dpi ct:hnull)))


(defun move-v2-x-y (v2 x y)
  (incf (v2-h v2) x)
  (incf (v2-v v2) y)
  v2)

(defmethod ncanvas-to-screen-point (self point)
  (ncanvas-to-screen-point (fm-parent self)
                          (move-v2-x-y point (px self) (py self))))

(defmethod res-to-res ((amount number) from-res to-res)
  (if to-res
      (round (* amount from-res) to-res)
    from-res))

(defmethod res-to-res ((point v2) from-res to-res)
  (nres-to-res (copy-v2 point) from-res to-res))

#+no-2e-h
(defmethod nres-to-res ((point v2) from-res to-res)
  (setf (v2-h point) (res-to-res (v2-h point) from-res to-res))
  (setf (v2-v point) (res-to-res (v2-v point) from-res to-res))
  point)

(defmethod res-to-res ((box rect) from-res to-res)
  (count-it :res-to-res)
  (nres-to-res (nr-copy (mkr 0 0 0 0) box) from-res to-res))

(defmethod nres-to-res :around (geo-thing from-res (to-res null))
  (declare (ignore from-res))
  geo-thing)

(defmethod nres-to-res ((box rect) from-res to-res)
  (setf (r-left box) (res-to-res (r-left box) from-res to-res))
  (setf (r-top box) (res-to-res (r-top box) from-res to-res))
  (setf (r-right box) (res-to-res (r-right box) from-res to-res))
  (setf (r-bottom box) (res-to-res (r-bottom box) from-res to-res))
  box)

(defun canvas-to-screen-box (self box)
  (count-it :canvas-to-screen-box)
  (nr-make-from-corners 
   (mkr 0 0 0 0)
   (ncanvas-to-screen-point self (r-top-left box))
   (ncanvas-to-screen-point self (r-bottom-right box))))

--- /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp	2006/06/04 13:19:59	NONE
+++ /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp	2006/06/04 13:19:59	1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
#|

Copyright (C) 2004 by Kenneth William Tilton

This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
 (http://opensource.franz.com/preamble.html), known as the LLGPL.

This library is distributed  WITHOUT ANY WARRANTY; without even 
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  

See the Lisp Lesser GNU Public License for more details.

|#

(defpackage #:gui-geometry
  (:nicknames #:geo)
  (:use #:common-lisp #:utils-kt #:cells)
  (:export #:geometer #:px #:py #:ll #:lt #:lr #:lb))--- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp	2006/06/04 13:19:59	NONE
+++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp	2006/06/04 13:19:59	1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
#|

Copyright (C) 2004 by Kenneth William Tilton

This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
 (http://opensource.franz.com/preamble.html), known as the LLGPL.

This library is distributed  WITHOUT ANY WARRANTY; without even 
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  

See the Lisp Lesser GNU Public License for more details.

|#

(in-package :gui-geometry)

;-----------------------------

(defstruct v2 
  (h 0 )
  (v 0 )
  )

#+(or)
(instance-slots (mkv2 1 2))

(defmethod print-object ((self v2) s)
  (format s "(~a ~a)" (v2-h self)(v2-v self)))

(defun mkv2 (h v) (make-v2 :h h :v v))

(defun v2= (a b)
  (and a b
    (= (v2-h a)(v2-h b))
    (= (v2-v a)(v2-v b))))

(defun v2-add (p1 p2)
  (make-v2 :h (+ (v2-h p1) (v2-h p2))
    :v (+ (v2-v p1) (v2-v p2))))

(defun v2-move (p1 x y)
  (make-v2 :h (+ (v2-h p1) x)
    :v (+ (v2-v p1) y)))

(defun v2-subtract (p1 p2)
  (make-v2 :h (- (v2-h p1) (v2-h p2))
    :v (- (v2-v p1) (v2-v p2))))

(defun v2-in-rect (v2 r)
  (mkv2 (min (r-right r) (max (r-left r) (v2-h v2)))
    (min (r-top r) (max (r-bottom r) (v2-v v2)))))

(defun v2-in-rect-ratio (v2 r)
  (assert (<= (r-left r) (v2-h v2) (r-right r)))
  (assert (<= (r-bottom r) (v2-v v2) (r-top r)))
  (mkv2 (div-safe (- (v2-h v2) (r-left r)) (r-width r))
    (div-safe (- (v2-v v2) (r-bottom r)) (r-height r))))

(defun div-safe (n d &optional (zero-div-return-value 1))
  (if (zerop d) zero-div-return-value (/ n d)))

(defmethod c-value-incf (c (base v2) (delta number))
  (declare (ignore c))
  (mkv2 (+ (v2-h base) delta)
    (+ (v2-v base) delta)))

(defmethod c-value-incf (c (base v2) (delta v2))
  (declare (ignore c))
  (v2-add base delta))

; synapse support
;
(defmethod delta-diff ((new v2) (old v2) (subtypename (eql 'v2)))
  (v2-subtract new old))

(defmethod delta-identity ((dispatcher number) (subtypename (eql 'v2)))
  (mkv2 0 0))

(defun long-v2 (long-hv)
    (c-assert (numberp long-hv))
    (multiple-value-bind (fv fh)
           (floor long-hv 65536)
          (mkv2 fh fv)))

(defun long-x (long-hv)
    (c-assert (numberp long-hv))
    (mod long-hv 65536))

(defun long-y (long-hv)
    (c-assert (numberp long-hv))
    (floor long-hv 65536))

[229 lines skipped]
--- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp	2006/06/04 13:19:59	NONE
+++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp	2006/06/04 13:19:59	1.1

[369 lines skipped]
--- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp	2006/06/04 13:19:59	NONE
+++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp	2006/06/04 13:19:59	1.1

[722 lines skipped]
--- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr	2006/06/04 13:19:59	NONE
+++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr	2006/06/04 13:19:59	1.1

[809 lines skipped]


From ktilton at common-lisp.net  Mon Jun  5 00:01:22 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sun,  4 Jun 2006 20:01:22 -0400 (EDT)
Subject: [cells-cvs] CVS cells/gui-geometry
Message-ID: <20060605000122.5C652111C9@common-lisp.net>

Update of /project/cells/cvsroot/cells/gui-geometry
In directory clnet:/tmp/cvs-serv2216/gui-geometry

Modified Files:
	defpackage.lisp geo-family.lisp geometer.lisp 
Log Message:
evolving geometry; refinement of test case 01c-cascade

--- /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp	2006/06/04 13:19:59	1.1
+++ /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp	2006/06/05 00:01:22	1.2
@@ -17,4 +17,46 @@
 (defpackage #:gui-geometry
   (:nicknames #:geo)
   (:use #:common-lisp #:utils-kt #:cells)
-  (:export #:geometer #:px #:py #:ll #:lt #:lr #:lb))
\ No newline at end of file
+  (:export #:geometer #:geo-zero-tl #:geo-inline
+    #:px #:py #:ll #:lt #:lr #:lb
+    #:u96ths #:udots #:uinches #:uin #:upoints #:upts #:u8ths #:u16ths #:u32nds
+    #:mkr #:v2-move #:l-height #:mkv2 #:^offset-within #:inset-lr #:v2-v #:v2-h
+    #:r-bounds 
+    #:lb 
+    #:cs-target-res 
+    #:nr-make 
+    #:r-contains 
+    #:collapsed 
+    #:g-box 
+    #:v2-in-rect-ratio 
+    #:v2-xlate 
+    #:v2-in-rect 
+    #:v2-add 
+    #:v2-subtract 
+    #:log2scr 
+    #:^lr-width 
+    #:px-maintain-pr 
+    #:outset 
+    #:py-maintain-pb 
+    #:cs-logical-dpi 
+    #:px-maintain-pl 
+    #:py-maintain-pt 
+    #:scr2log 
+    #:inset-width 
+    #:inset-height 
+    #:res-to-res 
+    #:logical-to-screen-point 
+    #:nres-to-res 
+    #:cs-logical-screen-resolution 
+    #:outl 
+    #:with-r-bounds 
+    #:r-inset 
+    #:ncopy-rect 
+    #:l 
+    #:r-height 
+    #:r-width 
+    #:r-top 
+    #:r-right 
+    #:r-bottom 
+    #:r-left 
+    #:l-width ))
--- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp	2006/06/04 13:19:59	1.1
+++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp	2006/06/05 00:01:22	1.2
@@ -55,16 +55,6 @@
                                    (c? (px-maintain-pl
                                         (^prior-sib-pr self (spacing .parent)))))))))))
 
-(defmodel geo-stack (geo-inline)
-  ()
-  (:default-initargs
-      :orientation :vertical))
-
-(defmodel geo-row (geo-inline)
-  ()
-  (:default-initargs
-      :orientation :horizontal))
-
 (defmacro a-stack ((&rest stack-args) &body dd-kids)
   `(mk-part ,(copy-symbol 'a-stack) (geo-inline)
       , at stack-args
--- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp	2006/06/04 13:19:59	1.1
+++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp	2006/06/05 00:01:22	1.2
@@ -30,6 +30,10 @@
    (w-box :cell nil :initform (mkr 0 0 0 0) :accessor w-box
      :documentation "bbox in window coordinate system")))
 
+(defmethod collapsed (other)
+  (declare (ignore other))
+  nil)
+
 ;;-------- Zero-zero Top Left ----------------------------
 ;;
 (defmodel geo-zero-tl (family) 



From ktilton at common-lisp.net  Mon Jun  5 00:01:22 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sun,  4 Jun 2006 20:01:22 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060605000122.A10AF111CC@common-lisp.net>

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

Modified Files:
	link.lisp md-slot-value.lisp propagate.lisp 
Log Message:
evolving geometry; refinement of test case 01c-cascade

--- /project/cells/cvsroot/cells/link.lisp	2006/05/20 06:32:19	1.9
+++ /project/cells/cvsroot/cells/link.lisp	2006/06/05 00:01:22	1.10
@@ -22,30 +22,14 @@
 (eval-when (compile load)
  (proclaim '(optimize (speed 3) (safety 0) (space 0) (debug 0))))
 
-
 (defun c-link-ex (used &aux (user (car *c-calculators*)))
-  (c-assert user)
-  (c-assert used)
   (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell
     (return-from c-link-ex nil))
-
-
-  ;
-  ; --------- debug stuff --------------
-  (c-assert user)
-  (c-assert (c-model user))
-  (c-assert (c-model used))
-
-  #+dfdbg (trc user "c-link > user, used" user used)
-  (c-assert (not (eq :eternal-rest (md-state (c-model user)))))
-  (c-assert (not (eq :eternal-rest (md-state (c-model used)))))
-  (count-it :c-link-entry)
-
+  (trc nil "c-link-ex entry: used=" used :user user)
   (multiple-value-bind (used-pos useds-len)
       (loop with u-pos
           for known in (cd-useds user)
           counting known into length
-            ;; do (print (list :data known length))
           when (eq used known)
           do
             (count-it :known-used)
@@ -56,7 +40,9 @@
       (trc nil "c-link > new user,used " user used)
       (count-it :new-used)
       (setf used-pos useds-len)
-      (push used (cd-useds user)))
+      (push used (cd-useds user))
+      (user-ensure used user) ;; 060604 experiment was in unlink
+      )
 
     (handler-case
         (setf (sbit (cd-usage user) used-pos) 1)
@@ -68,7 +54,6 @@
   used)
 
 
-
 ;--- c-unlink-unused --------------------------------
 
 (defun c-unlink-unused (c &aux (usage (cd-usage c)))
@@ -81,7 +66,10 @@
                                 (count-it :unlink-unused)
                                 (c-unlink-user (car useds) c)
                                 (rplaca useds nil))
-                            (user-ensure (car useds) c))))
+                            (progn
+                              ;; moved into c-link-ex 060604 (user-ensure (car useds) c)
+                              )
+                            )))
                    (if (cdr useds)
                        (progn
                          (nail-unused (cdr useds))
--- /project/cells/cvsroot/cells/md-slot-value.lisp	2006/05/30 02:47:45	1.15
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/05 00:01:22	1.16
@@ -42,13 +42,12 @@
   (if c
       (prog1
           (with-integrity ()
-            (c-value-ensure-current c :md-slot-value))
+            (c-value-ensure-current c))
         (when (car *c-calculators*)
           (c-link-ex c)))
     (values (bd-slot-value self slot-name) nil)))
   
-(defun c-value-ensure-current (c &optional (debug-id :anon-caller))
-  (declare (ignorable debug-id))
+(defun c-value-ensure-current (c)
   (count-it :c-value-ensure-current)
   (trc nil "c-value-ensure-current >" c)
   (cond
@@ -59,7 +58,7 @@
 
    ((or (not (c-validp c))
       (some (lambda (used)
-              (c-value-ensure-current used :recursive-used)
+              (c-value-ensure-current used)
               (trc nil "comparing pulses (user, used): " (c-pulse c)(c-pulse used))
               (when (and (c-changed used) (> (c-pulse used)(c-pulse c)))
                  (trc nil "used changed" c used)
--- /project/cells/cvsroot/cells/propagate.lisp	2006/05/30 02:47:45	1.13
+++ /project/cells/cvsroot/cells/propagate.lisp	2006/06/05 00:01:22	1.14
@@ -165,11 +165,11 @@
       (with-integrity (:tell-dependents c)
         (assert (null *c-calculators*))
         (let ((*causation* causation))
-          (trc nil "c-propagate-to-users > notifying users of" c)
+          (trc "c-propagate-to-users > notifying users of" c (mapcar 'c-slot-name (c-users c)))
           (dolist (user (c-users c))
             (unless (member (cr-lazy user) '(t :always :once-asked))
               (trc nil "propagating to user is (used,user):" c user)
-              (c-value-ensure-current user :user-propagation))))))))
+              (c-value-ensure-current user))))))))
 
 
 



From ktilton at common-lisp.net  Mon Jun  5 00:01:22 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sun,  4 Jun 2006 20:01:22 -0400 (EDT)
Subject: [cells-cvs] CVS cells/tutorial
Message-ID: <20060605000122.D93EA111C9@common-lisp.net>

Update of /project/cells/cvsroot/cells/tutorial
In directory clnet:/tmp/cvs-serv2216/tutorial

Modified Files:
	01c-cascade.lisp 
Log Message:
evolving geometry; refinement of test case 01c-cascade

--- /project/cells/cvsroot/cells/tutorial/01c-cascade.lisp	2006/05/30 02:47:45	1.1
+++ /project/cells/cvsroot/cells/tutorial/01c-cascade.lisp	2006/06/05 00:01:22	1.2
@@ -1,31 +1,94 @@
-#| Now we have automatic state management (including change propagation)
+#| 
+
+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. :)]
+In this case: len->area->brightness
+Also: len->width->area->brightness
+
+That leads to some complications I will discuss, but no assertions here
+enforce correct behavior in re those complications. Soon. :)
 
 |#
 
 (defpackage #:tu-depth (:use :cl :cells))
 (in-package #:tu-depth)
 
+(defmacro start-finish (key rule)
+  `(progn
+     (print (list :start ,key))
+     (prog1
+         (progn ,rule)
+       (print (list :finish ,key)))))
 
 (defmodel rectangle ()
-  ((area :initarg :area :accessor area
-     :initform (c? (print :compue-area)
-                 (* (len self)(width self))))
+  ((lumens :initform 1000000 :reader lumens)
    (len :initarg :len :accessor len
-     :initform (c? (print :compute-len)
-                 (* 2 (width self))))
+     :initform (c? (start-finish :len
+                     (* 2 (width self)))))
+   (area :initarg :area :accessor area
+     :initform (c? (start-finish :area
+                     (* (len self)(width self)))))
    (width :initarg :width :accessor width
-     :initform (c? (print :compute-width)
-                 (floor (len self) 2)))))
+     :initform (c? (start-finish :width
+                     (floor (len self) 2))))
+   (brightness :reader brightness
+     :initform (c? (start-finish :brightness
+                     (/ (^lumens) (^area)))))
+   ))
 
 #+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)))
+(let ((r (make-instance 'rectangle :len (c-in 100))))
+  (cells::ct-assert (eql 50 (width r)))
+  (cells::ct-assert (eql 5000 (area r)))
+  (cells::ct-assert (eql 200 (brightness r)))
   (cells::ct-assert (= 1000 (setf (len r) 1000)))
-  (cells::ct-assert (eql 500000 (area r))))
+  (cells::ct-assert (eql 500000 (area r)))
+  (cells::ct-assert (eql 2 (brightness r))))
+
+#| --- discussion ----------------------------
+
+The output in Cells is:
+
+(:START :AREA) 
+(:START :WIDTH) 
+(:finish :WIDTH) 
+(:finish :AREA) 
+(:START :BRIGHTNESS) 
+(:finish :BRIGHTNESS) 
+(CELTK::ATTEMPTING (EQL 50 (WIDTH R))) 
+(CELTK::ATTEMPTING (EQL 5000 (AREA R))) 
+(CELTK::ATTEMPTING (EQL 200 (BRIGHTNESS R))) 
+(CELTK::ATTEMPTING (= 1000 (SETF (LEN R) 1000))) 
+0> c-propagate-to-users > notifying users of | [i :=[24]LEN/#<RECTANGLE>] | (AREA WIDTH)
+
+Notice here that the LEN cell is about to tell both the width and area to recalculate,
+since area depends (of course) on len and (rather artificially) width also derives
+from LEN.
+
+ie, This example has accidentally deviated into more complexity than intended. But we are 
+approaching these issues anyay, so I will leave it for now. We can always break it up
+later.
+
+Let's continue:
+
+(:START :WIDTH) 
+(:finish :WIDTH) 
+(:START :AREA) 
+(:finish :AREA) 
+
+Fine, now here comes the challenge. Width is also going to tell area to recalculate:
+
+0> c-propagate-to-users > notifying users of | [? :<vld>=[24]WIDTH/#<RECTANGLE>] | (AREA)
+0> c-propagate-to-users > notifying users of | [? :<vld>=[24]AREA/#<RECTANGLE>] | (BRIGHTNESS)
+
+Correct: Area does not actually run its rule since it already did so when notified by LEN,
+ but it does propagate to brightness.
+
+(:START :BRIGHTNESS) 
+(:finish :BRIGHTNESS)  
+(CELTK::ATTEMPTING (EQL 500000 (AREA R))) 
+(CELTK::ATTEMPTING (EQL 2 (BRIGHTNESS R))) 
 
+|#
\ No newline at end of file



From ktilton at common-lisp.net  Tue Jun  6 04:54:11 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue,  6 Jun 2006 00:54:11 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060606045411.2A32F44054@common-lisp.net>

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

Added Files:
	cells-manifesto.txt 
Log Message:
Doc, OK?


--- /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/06 04:54:11	NONE
+++ /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/06 04:54:11	1.1

                                Cells In A Nutshell

The Cells library as it stands is all about doing interesting things with slots of CLOS instances.
Nothing says a global variable could not be mediated by a Cell, and indeed one Cells user is 
known to have experimented with that. Also, some work was done on having slots of DEFSTRUCTs mediated
by Cells. But for the rest of this exposition let's just talk about CLOS slots and instances.

The Cells library allows the programmer to specify at make-instance time that a slot of an instance
be mediated for the life of that instance by one of:

   -- a so-called "input" Cell;
   -- a "ruled" Cell; or
   -- no Cell at all.

Note that "slot of an instance" is not the same as "slot of a class". A vital feature of the Cells library
is that different instances may do different things Cells-wise with the same slot.

A slot mediated by an input Cell may be assigned new values at runtime. It is an error to assign a new
value to a slot of an instance not mediated by any Cell. Ruled Cells come with an instance-specific 
rule in the form of an anonymous function of two variables, the instance owning the slot and the prior value
(if any) computed by the rule. These rules consist of arbitrarily complex Common Lisp code, and are invoked
immediately after instance initialization or, if they are declared lazy, when their slot readers are invoked. 

When a rule runs, any dynamic read (either expressly in the rule source or during the execution of 
some function invoked by the rule) of a slot of any instance mediated by a Cell of any type establishes a
runtime dependency of the ruled cell on the slot of the instance that was read. Note then that thanks
to code branching, dependencies can vary after every rule invocation.

When application code assigns a new value to an input Cell (a quick way of saying an instance slot mediated by
an input Cell) -- typically by code polling OS events or a socket or an input device -- a cascade of recalculation
ensues to bring direct and indirect ruled dependents current with the new value assigned to the input Cell.

To allow the emergent data animation model to operate usefully on the world outside the model--if only to
update the screen--programmers may specify so-called observer callbacks dispatched according to: slot name, 
instance, new value, old value, and whether the old value actually existed (false only on the first go).

Finally, to make it possible for such a declarative model to talk intelligibly to imperative systems such as
Tcl/Tk which sometimes requires a precise sequence of commands for something to work at all, a mechanism exists by
which client code can (a) queue tasks for execution after a data change has fully propagated and (b) process
those tasks with a client-supplied handler. Tasks are queued with arbitrary keying data which can be used by 
the handler to sort or compress the queued tasks.

                                          Data Integrity

When application code assigns to some input cell X, the Cells engine guarantees:

  - recomputation exactly once of all and only state affected by the change to X, directly or indirectly through 
    some intermediate datapoint. note that if A depends on B, and B depends on X, when B gets recalculated
    it may come up with the same value as before. In this case A is not considered to have been affected
    by the change to X and will not be recomputed.

  - recomputations, when they read other datapoints, must see only values current with the new value of X.
    Example: if A depends on B and X, and B depends on X, when A reads B it must return a value recomputed from
    the new value of X.

  - similarly, client observer callbacks must see only values current with the new value of X; and

  - a corollary: should a client observer SETF a datapoint Y, all the above must
    happen with values current with not just X, but also with the value of Y /prior/
    to the change to Y.

  - Deferred "client" code must see only values current with X and not any values current with some
    subsequent change to Y queued by an observer

                                          Benefits

Program state guaranteed to be self-consistent, without programmer effort. Dependencies are identified
by the engine, and change propagation happens automatically.

Greater object re-use. Slots of instances can be authored with rules, not just literal values. In a sense,
we get greater reuse by allowing instances to override slot derivations instance by instance. But not slot
expressions, which are still class-oriented.

Natural decomposition of overall application complexity into so many simple rules and slot observers.

                                       Applications

Any application that must maintain an interesting, long-lived data model incorporating a stream of unpredictable 
data. Two examples: any GUI application and a RoboCup soccer client.

An application needing to shadow data between two systems. Examples: a Lisp GUI imlemented by thinly wrapping a 
C GUI library, where Lisp-land activity must be propagated to the C GUI, and C GUI events must propagate
to Lisp-land. See the Cells-Gtk or Celtk projects. Also, a persistent CLOS implementation that must echo 
CLOS instance data into, say, SQL tables.


From ktilton at common-lisp.net  Tue Jun  6 17:40:41 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue,  6 Jun 2006 13:40:41 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060606174041.448F8415E@common-lisp.net>

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

Modified Files:
	cells-manifesto.txt 
Log Message:
mo better doc

--- /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/06 04:54:10	1.1
+++ /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/06 17:40:41	1.2
@@ -1,11 +1,41 @@
 
-                                Cells In A Nutshell
-
+                                
+Cells In A Nutshell
+-------------------
 The Cells library as it stands is all about doing interesting things with slots of CLOS instances.
 Nothing says a global variable could not be mediated by a Cell, and indeed one Cells user is 
 known to have experimented with that. Also, some work was done on having slots of DEFSTRUCTs mediated
 by Cells. But for the rest of this exposition let's just talk about CLOS slots and instances.
 
+DEFMODEL and Slot types
+-----------------------
+Classes, some of whose slots may be mediated by Cells, are defined by DEFMODEL, which is exactly
+like DEFCLASS but adds support for two slot definition options, :cell and :unchanged-if.
+
+   :cell {nil | t | :ephemeral}
+
+:cell is optional. The default is ":cell t", meaning the Cells engine will manage the slot. 
+Specifying NIL signifies that this slot is entirely 
+outside any handling by the Cells engine; it is just a plain CLOS slot. 
+
+Specifying :ephemeral causes the Cells engine to reset the apparent slot 
+value to NIL immediately and only after fully propagating any value assumed by the slot, either
+by assignment to an input Cell (the vastly more common case) or by a rule calculation.
+
+Ephemeral cells are necessary to correctly model events in the otherwise steady-state 
+spreadsheet paradigm.
+
+  :unchanged-if <function-name>
+
+Specifying :unchanged-if is optional. [Come to think of it, it should be an error to specify
+both :cell nil and :unchanged-if.] If specified, the named function is a predicate
+of two arguments, the new and old value in that order. The predicate determines if a subsequent
+slot value (either computed or assigned to an input) is unchanged in the sense that no propagation
+is necessary, either to dependent ruled cells or (getting ahead of ourselves) "on change" observers.
+The default unchanged test is EQL.
+
+Cell types
+----------
 The Cells library allows the programmer to specify at make-instance time that a slot of an instance
 be mediated for the life of that instance by one of:
 
@@ -13,36 +43,77 @@
    -- a "ruled" Cell; or
    -- no Cell at all.
 
-Note that "slot of an instance" is not the same as "slot of a class". A vital feature of the Cells library
-is that different instances may do different things Cells-wise with the same slot.
-
-A slot mediated by an input Cell may be assigned new values at runtime. It is an error to assign a new
-value to a slot of an instance not mediated by any Cell. Ruled Cells come with an instance-specific 
-rule in the form of an anonymous function of two variables, the instance owning the slot and the prior value
-(if any) computed by the rule. These rules consist of arbitrarily complex Common Lisp code, and are invoked
-immediately after instance initialization or, if they are declared lazy, when their slot readers are invoked. 
+Note that different instances of the same class may do different things Cells-wise with the same slot.
+One label widget may have a fixed width of 42 and text "Hi, Mom!", where another might have
+an input Cell mediating the text (so edit logic can assign new values as the user types) and a
+rule mediating the width so the widget can have a minimum width of 42(so it does not disappear altogether)
+yet grow based on text length and relevant font metrics to always leave room for one more character 
+(if the GUI design calls for that).
+
+To summarize, the class specification supplied with DEFMODEL specifies whether a slot can ever
+be managed by the Cells engine. For those that can, at and only at instance initialization time,
+different instances can have different Cell types mediating the same slot.
+
+Input Cells
+-----------
+A slot mediated by an input Cell may be assigned new values at runtime. These are how Cell-based models
+get data from the world outside the model -- it cannot be rules all the way down. Typically, these
+input assignements are made by code polling OS events via some GetNextEvent API call, or by callbacks
+registered with an event system such as win32 WindowProc functions. Other code may poll sockets or 
+serial inputs from some external device.
+
+Ruled Cells
+-----------
+Ruled Cells come with an instance-specific  rule in the form of an anonymous function of two variables, 
+the instance owning the slot and the prior value (if any) computed by the rule. These rules consist of 
+arbitrarily complex Common Lisp code, and are invoked immediately after instance initialization or, if 
+they are declared lazy, when their slot readers are invoked. 
 
 When a rule runs, any dynamic read (either expressly in the rule source or during the execution of 
 some function invoked by the rule) of a slot of any instance mediated by a Cell of any type establishes a
 runtime dependency of the ruled cell on the slot of the instance that was read. Note then that thanks
 to code branching, dependencies can vary after every rule invocation.
 
+Dataflow
+--------
 When application code assigns a new value to an input Cell (a quick way of saying an instance slot mediated by
 an input Cell) -- typically by code polling OS events or a socket or an input device -- a cascade of recalculation
 ensues to bring direct and indirect ruled dependents current with the new value assigned to the input Cell.
 
+No Cell at All
+--------------
+Because of all that, it is an error to assign a new value to a slot of an instance not mediated by any Cell. 
+The Cells engine can do a handy optimization by treating such slots as constants and not creating dependencies when ruled
+Cells read these. But then we cannot let these Cells vary and still guarantee data integrity, because
+we no longer know who else to update in light of such variation. The optimization, by the way, extends to
+eliminating ruled Cells which, after any computation, end up not depending on any other cell.
+
+Again, note that this is different than specifying ":cell nil" for some slot. Here, the Cells engine
+has been told to manage some slot, but for some instance the slot has been authored to bear some value
+for the lifetime of that instance.
+
+Observers
+---------
 To allow the emergent data animation model to operate usefully on the world outside the model--if only to
 update the screen--programmers may specify so-called observer callbacks dispatched according to: slot name, 
 instance, new value, old value, and whether the old value actually existed (false only on the first go).
 
+It is legal for observer code to assign to input Cells, but (a) special syntax is required to defer executuion
+until the observed state change has fully propagated; and (b) doing so compromises the declarative
+quality of an application -- one can no longer look to one rule to see how a slot (in this case the
+input slot being assigned by the observer) gets its value. A reasonable usage might be one with
+a cycle, where changing slot A requires a change to slot B, and changing slot B requires a change to
+slot A, such as the scroll thumb position and the amount a document has been scrolled.
+
 Finally, to make it possible for such a declarative model to talk intelligibly to imperative systems such as
 Tcl/Tk which sometimes requires a precise sequence of commands for something to work at all, a mechanism exists by
 which client code can (a) queue tasks for execution after a data change has fully propagated and (b) process
 those tasks with a client-supplied handler. Tasks are queued with arbitrary keying data which can be used by 
 the handler to sort or compress the queued tasks.
 
-                                          Data Integrity
-
+                                          
+Data Integrity
+--------------
 When application code assigns to some input cell X, the Cells engine guarantees:
 
   - recomputation exactly once of all and only state affected by the change to X, directly or indirectly through 
@@ -63,8 +134,8 @@
   - Deferred "client" code must see only values current with X and not any values current with some
     subsequent change to Y queued by an observer
 
-                                          Benefits
-
+Benefits
+--------
 Program state guaranteed to be self-consistent, without programmer effort. Dependencies are identified
 by the engine, and change propagation happens automatically.
 
@@ -74,12 +145,120 @@
 
 Natural decomposition of overall application complexity into so many simple rules and slot observers.
 
-                                       Applications
-
+Applications
+------------
 Any application that must maintain an interesting, long-lived data model incorporating a stream of unpredictable 
 data. Two examples: any GUI application and a RoboCup soccer client.
 
 An application needing to shadow data between two systems. Examples: a Lisp GUI imlemented by thinly wrapping a 
 C GUI library, where Lisp-land activity must be propagated to the C GUI, and C GUI events must propagate
 to Lisp-land. See the Cells-Gtk or Celtk projects. Also, a persistent CLOS implementation that must echo 
-CLOS instance data into, say, SQL tables.
\ No newline at end of file
+CLOS instance data into, say, SQL tables.
+
+Prior Art
+---------
+The entire constraint programming field, beginning I guess with Guy Steele's
+PhD Thesis in which he develops a constraint programming language or two:
+  http://portal.acm.org/citation.cfm?id=889490&dl=ACM&coll=ACM
+  http://www.cs.utk.edu/~bvz/quickplan.html
+
+Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963.
+Steele himself cites Sketchpad as inexlicably unappreciated prior
+art to his Constraints system:
+
+Garnet's KR: http://www.cs.cmu.edu/~garnet/
+Also written in Lisp. Cells looks  much like KR, though Cells was 
+developed in ignorance of KR (or any other prior art). KR has 
+an astonishing number of backdoors to its constraint
+engine, none of which have turned out to be necessary for Cells.
+
+COSI:
+ "The Constraint Sequencing Infrastructure (COSI) is an extension to
+the Common Lisp Object System (*(CLOS)) which supports a constraint
+based object-oriented programming model. .....
+
+"A constraint is a specialized method which will be automatically
+re-run by the COSI infrastructure whenever any of its input values
+change. Input values are any of the object attributes that are
+accessed by the constraint, and which are therefore assumed to
+alter the processing within the constraint. 
+
+"Whenever a state change occurs those constraints which depend upon
+that state are added to a propagation queue. When the system is
+queried a propagation cycle runs ensuring that the state of the
+system is consistent with all constraints prior to returning a value."
+-- http://www.cliki.net/ACL2/COSI?source
+
+Adobe Adam:
+http://opensource.adobe.com/group__asl__overview.html#asl_overview_intro_to_adam_and_eve
+"Adam is a modeling engine and declarative language for describing constraints and 
+relationships on a collection of values, typically the parameters to an 
+application command. When bound to a human interface (HI) Adam provides 
+the logic that controls the HI behavior. Adam is similar in concept to a spreadsheet 
+or a forms manager. Values are set and dependent values are recalculated. 
+Adam provides facilities to resolve interrelated dependencies and to track 
+those dependencies, beyond what a spreadsheet provides."
+
+See also:
+ The spreadsheet paradigm: http://www.cs.utk.edu/~bvz/active-value-spreadsheet.html
+ The dataflow paradigm: http://en.wikipedia.org/wiki/Dataflow
+ Reactive programming: http://www.haskell.org/yampa/AFPLectureNotes.pdf
+ Frame-based programming
+
+Commentary
+----------
+-- Jack Unrue, comp.lang.lisp
+"Cells provides the plumbing for data dependency management which every 
+non-trivial program must have; a developer using Cells can focus on 
+computing program state and reacting to state changes, leaving Cells to worry about
+how that state is propagated. Cells does this by enabling a declarative 
+mechanism built via an extension to CLOS, and hence achieves its goal in a way 
+that meshes well with with typical Common Lisp programming style."
+
+-- Bill Clementson, http://bc.tech.coop/blog/030911.html
+"Kenny Tilton has been talking about his Cells implementation on comp.lang.lisp 
+for some time but I've only just had a look at it over the past few evenings. 
+It's actually pretty neat. Kenny describes Cells as, conceptually, analogous to 
+a spreadsheet cell (e.g. -- something in which you can put a value or a formula 
+and have it updated automatically based on changes in other "cell" values). 
+Another way of saying this might be that Cells allows you to define classes 
+whose slots can be dynamically (and automatically) updated and for which 
+standard observers can be defined that react to changes in those slots."
+
+-- "What is Cells?", Cells-GTk FAQ, http://common-lisp.net/project/cells-gtk/faq.html#q2
+"If you are at all familiar with developing  moderately complex software that 
+is operated through a GUI, then you have probably 
+learned this lesson: Keeping what is presented through the GUI in-sync with what 
+the user is allowed to do, and in-sync with the computational state of the 
+program is often tedious, complicated work. .... Cells-GTK helps 
+with these tasks by providing an abstraction over the details; each of the tasks 
+just listed can be controlled by (a) formula that specify the value of 
+attributes of graphic features in the part-subpart declaration (that declaration 
+is called 'defpart' in cells-gtk); and, (b) formula that specify the value of CLOS slots."
+
+-- Phillip Eby, PyCells and peak.events, 
+... http://www.eby-sarna.com/pipermail/peak/2006-May/002545.html
+"What I discovered is quite cool.  The Cells system *automatically 
+discovers* dynamic dependencies, without having to explicitly specify that 
+X depends on Y, as long as X and Y are both implemented using cell 
+objects.  The system knows when you are computing a value for X, and 
+registers the fact that Y was read during this computation, thus allowing 
+it to automatically invalidate the X calculation if Y changes.
+
+"...Aside from the automatic dependency 
+detection, the cells system has another trick that is able to significantly 
+reduce the complexity of event cascades, similar to what I was trying (but 
+failing) to do using the "scheduled thread" concept in peak.events.
+
+"Specifically, the cells system understands how to make event-based updates 
+orderly and deterministic, in a way that peak.events cannot.  It 
+effectively divides time into "propagation" and "non-propagation" 
+states.  Instead of simply making callbacks whenever a computed value 
+changes, the system makes orderly updates by queueing invalidated cells for 
+updating.  Also, if you write code that sets a new value imperatively (as 
+opposed to it being pulled declaratively), the actual set operation is 
+deferred until all computed cells are up-to-date with the current state of 
+the universe."
+
+
+                                
\ No newline at end of file



From ktilton at common-lisp.net  Tue Jun  6 18:19:11 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue,  6 Jun 2006 14:19:11 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060606181911.1222714003@common-lisp.net>

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

Modified Files:
	cells-manifesto.txt 
Log Message:


--- /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/06 17:40:41	1.2
+++ /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/06 18:19:11	1.3
@@ -260,5 +260,7 @@
 deferred until all computed cells are up-to-date with the current state of 
 the universe."
 
+-- Peter Seibel, comp.lang.lisp
+"I couldn't find anything that explained what it was and why I should care."
 
                                 
\ No newline at end of file



From ktilton at common-lisp.net  Wed Jun  7 22:12:55 2006
From: ktilton at common-lisp.net (ktilton)
Date: Wed,  7 Jun 2006 18:12:55 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060607221255.362151A005@common-lisp.net>

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

Modified Files:
	cells-manifesto.txt link.lisp md-slot-value.lisp 
Log Message:


--- /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/06 18:19:11	1.3
+++ /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/07 22:12:55	1.4
@@ -260,7 +260,14 @@
 deferred until all computed cells are up-to-date with the current state of 
 the universe."
 
--- Peter Seibel, comp.lang.lisp
+Uncommentary
+------------
+-- Peter Seibel, comp.lang.lisp:
 "I couldn't find anything that explained what it was and why I should care."
 
+-- Alan Crowe, comp.lang.lisp:
+"Further confession: I'm bluffing. I've grasped that Cells is
+interesting, but I haven't downloaded it yet, and I haven't
+checked out how it works or what /exactly/ it does."
+
                                 
\ No newline at end of file
--- /project/cells/cvsroot/cells/link.lisp	2006/06/05 00:01:22	1.10
+++ /project/cells/cvsroot/cells/link.lisp	2006/06/07 22:12:55	1.11
@@ -54,7 +54,7 @@
   used)
 
 
-;--- c-unlink-unused --------------------------------
+;--- unlink unused --------------------------------
 
 (defun c-unlink-unused (c &aux (usage (cd-usage c)))
   (when (cd-useds c)
@@ -87,7 +87,6 @@
 
 ; ---------------------------------------------
 
-
 (defun cd-usage-clear-all (c)
   (loop with a = (cd-usage c)
         for bitn below (array-dimension a 0)
--- /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/05 00:01:22	1.16
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/07 22:12:55	1.17
@@ -151,8 +151,12 @@
     (c-setting-debug self slot-name c new-value))
   
   (unless c
-    (c-break "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized as inputp"
-      slot-name self))
+    (c-break "cellular slot ~a of ~a cannot be SETFed because it is not 
+mediated by a Cell with :inputp t. To achieve this, the initial value ~s -- whether 
+supplied as an :initform, :default-initarg, or at make-instance time via 
+an :initarg -- should be wrapped in either macro C-IN or C-INPUT. 
+In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
+      slot-name self (slot-value self slot-name)))
 
   (when *defer-changes*
     (c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c))



From ktilton at common-lisp.net  Wed Jun  7 22:12:55 2006
From: ktilton at common-lisp.net (ktilton)
Date: Wed,  7 Jun 2006 18:12:55 -0400 (EDT)
Subject: [cells-cvs] CVS cells/doc
Message-ID: <20060607221255.68AC01A006@common-lisp.net>

Update of /project/cells/cvsroot/cells/doc
In directory clnet:/tmp/cvs-serv13795/doc

Modified Files:
	motor-control.lisp 
Log Message:


--- /project/cells/cvsroot/cells/doc/motor-control.lisp	2006/03/22 04:08:35	1.2
+++ /project/cells/cvsroot/cells/doc/motor-control.lisp	2006/06/07 22:12:55	1.3
@@ -58,6 +58,11 @@
 	      :initform (c? (ecase (^status) (:on :open) (:off :closed))))
    (temp :initarg :temp :accessor temp :initform (c-in 0))))
 
+#+test
+(progn 
+  (cells-reset)
+  (setf (status (make-instance 'motor :status :on)) 42))
+
 #|
 
 Note that "status" is a cell with no initial value or formula, "fuel-pump" is 



From ktilton at common-lisp.net  Wed Jun  7 22:13:41 2006
From: ktilton at common-lisp.net (ktilton)
Date: Wed,  7 Jun 2006 18:13:41 -0400 (EDT)
Subject: [cells-cvs] CVS Celtk
Message-ID: <20060607221341.C6B5522008@common-lisp.net>

Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv13881

Modified Files:
	CELTK.lpr Celtk.asd Celtk.lisp demos.lisp font.lisp 
	item-pictorial.lisp layout.lisp load.lisp lotsa-widgets.lisp 
	ltktest-ci.lisp multichoice.lisp run.lisp scroll.lisp 
	tk-interp.lisp tk-object.lisp tk-structs.lisp widget.lisp 
Log Message:
Resurrect under Lispworks

--- /project/cells/cvsroot/Celtk/CELTK.lpr	2006/06/03 12:12:19	1.15
+++ /project/cells/cvsroot/Celtk/CELTK.lpr	2006/06/07 22:13:41	1.16
@@ -11,8 +11,8 @@
                  (make-instance 'module :name "tk-events.lisp")
                  (make-instance 'module :name "tk-object.lisp")
                  (make-instance 'module :name "widget.lisp")
-                 (make-instance 'module :name "font.lisp")
                  (make-instance 'module :name "layout.lisp")
+                 (make-instance 'module :name "font.lisp")
                  (make-instance 'module :name "timer.lisp")
                  (make-instance 'module :name "menu.lisp")
                  (make-instance 'module :name "label.lisp")
@@ -35,7 +35,9 @@
   :projects (list (make-instance 'project-module :name
                                  "..\\cells\\cells")
                   (make-instance 'project-module :name
-                                 "C:\\1-devtools\\cffi\\cffi"))
+                                 "C:\\1-devtools\\cffi\\cffi")
+                  (make-instance 'project-module :name
+                                 "..\\Cells\\gui-geometry\\gui-geometry"))
   :libraries nil
   :distributed-files nil
   :internally-loaded-files nil
--- /project/cells/cvsroot/Celtk/Celtk.asd	2006/05/26 17:50:36	1.9
+++ /project/cells/cvsroot/Celtk/Celtk.asd	2006/06/07 22:13:41	1.10
@@ -12,7 +12,7 @@
   :licence "Lisp LGPL"
   :description "Tcl/Tk with Cells Inside(tm)"
   :long-description "A Cells-driven portable GUI, ultimately implmented by Tcl/Tk"
-  :depends-on (:cells :cffi)
+  :depends-on (:cells :cffi :gui-geometry)
   :serial t
   :components ((:file "Celtk")
                (:file "tk-structs")
@@ -20,8 +20,8 @@
                (:file "tk-events")
                (:file "tk-object")
                (:file "widget")
-               (:file "font")
                (:file "layout")
+               (:file "font")
                (:file "timer")
                (:file "menu")
                (:file "label")
@@ -35,9 +35,9 @@
                (:file "item-shaped")
                (:file "composites")
                (:file "frame")
+               (:file "fileevent")
                (:file "togl")
                (:file "run")
-	       (:file "fileevent")
-               (:file "ltktest-ci")
+	         (:file "ltktest-ci")
                (:file "lotsa-widgets")
                (:file "demos")))
--- /project/cells/cvsroot/Celtk/Celtk.lisp	2006/06/03 12:04:37	1.29
+++ /project/cells/cvsroot/Celtk/Celtk.lisp	2006/06/07 22:13:41	1.30
@@ -16,14 +16,14 @@
 
 |#
 
-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.29 2006/06/03 12:04:37 ktilton Exp $
+;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.30 2006/06/07 22:13:41 ktilton Exp $
 
 (defpackage :celtk
   (:nicknames "CTK")
   (:use :common-lisp :utils-kt :cells :cffi)
   (:export
-   #:<1> #:tk-event-type #:xsv #:name #:x-root #:y-root
-   #:title$ #:pop-up
+   #:<1> #:tk-event-type #:xsv #:name #:x #:y #:x-root #:y-root
+   #:title$ #:pop-up #:path #:parent-path #:^keyboard-modifiers #:keyboard-modifiers
    #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:text-widget
    #:mk-panedwindow
    #:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label
@@ -62,7 +62,6 @@
 
 (define-symbol-macro .tkw (nearest self window))
 
-
 ; --- tk-format --- talking to wish/Tk -----------------------------------------------------
 
 (defconstant +tk-client-task-priority+
@@ -133,11 +132,12 @@
       ; --- debug stuff ---------------------------------
       ;
 
-      (let ((yes '( "photo"))
-            (no  '()))
+      (let ((yes '())
+            (no  '("font")))
         (declare (ignorable yes no))
-        (when (and (find-if (lambda (s) (search s tk$)) yes)
-                        (not (find-if (lambda (s) (search s tk$)) no)))
+        (when (and (or ;; (null yes)
+                     (find-if (lambda (s) (search s tk$)) yes))
+                (not (find-if (lambda (s) (search s tk$)) no)))
           (format t "~&tk> ~a~%" tk$)))
       (assert *tki*)
 
@@ -194,7 +194,8 @@
   (format nil "{~{~a~^ ~}}" (mapcar 'tk-send-value values)))
 
 (defmethod parent-path ((nada null)) "")
-(defmethod parent-path ((self t)) (path self))
+(defmethod parent-path ((other t)) "")
+
 
 ; --- tk eval  ----------------------------------------------------
 
@@ -213,6 +214,9 @@
   (tk-format :grouped (apply 'format nil tk-form$ fmt-args))
   (parse-tcl-list-result (tcl-get-string-result *tki*)))
 
+#+test
+(parse-tcl-list-result "-ascent 58 -descent 15 -linespace 73 -fixed 0")
+
 (defun parse-tcl-list-result (result &aux item items)
   (when (plusp (length result))
     (trc nil "parse-tcl-list-result" result)
@@ -239,5 +243,6 @@
           else do (gather-item)
             (setf item nil)
           else do (push ch item)
-          finally (return (nreverse items))))))
+          finally (gather-item)
+            (return (nreverse items))))))
         
\ No newline at end of file
--- /project/cells/cvsroot/Celtk/demos.lisp	2006/06/03 12:04:37	1.21
+++ /project/cells/cvsroot/Celtk/demos.lisp	2006/06/07 22:13:41	1.22
@@ -18,10 +18,11 @@
 
 (in-package :celtk-user)
 
+
 (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package
   (test-window 
    ;;'place-test
-   ;;'one-button-window
+   ;; 'one-button-window
    ;;'ltktest-cells-inside
    ;;'menu-button-test
    ;;'spinbox-test
@@ -34,14 +35,14 @@
   (:default-initargs
       :kids (c? (the-kids                
                  (mk-label :text "hi, Mom"
-                   :x 100
-                   :y 20)))))
+                   :px 100
+                   :py 20)))))
 
 (defmodel one-button-window (window)
   ()
   (:default-initargs
       :kids (c? (the-kids                
-                 (mk-menubar
+                 #+shhhh (mk-menubar
                   :kids (c? (the-kids
                              (mk-menu-entry-cascade-ex (:label "File")
                                (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed"))
--- /project/cells/cvsroot/Celtk/font.lisp	2006/05/24 20:38:54	1.4
+++ /project/cells/cvsroot/Celtk/font.lisp	2006/06/07 22:13:41	1.5
@@ -22,7 +22,7 @@
 
 (eval-when (compile load eval)
   (export '(make-tkfinfo tkfinfo-family tkfinfo-size tkfinfo-slant tkfinfo-ascent  tkfinfo-linespace tkfinfo-fixed
-             tkfont-id tkfont-info bounds-offset tkfinfo-ascent tkfont-height tkfont-ascent 
+             tkfont-id tkfont-info tkfinfo-ascent tkfont-height tkfont-ascent 
              tkfinfo-descent ^tkfont-descent ^tkfont-find
              tkfinfo tkfinfo-em ^tkfont-em 
              line-up line-down tkfont-size-info)))
--- /project/cells/cvsroot/Celtk/item-pictorial.lisp	2006/05/24 20:38:54	1.2
+++ /project/cells/cvsroot/Celtk/item-pictorial.lisp	2006/06/07 22:13:41	1.3
@@ -34,7 +34,7 @@
     -disabledforeground))
 
 
-(deftk image (item)
+(deftk image-item (item)
   ()
   (:tk-spec image
     -state
--- /project/cells/cvsroot/Celtk/layout.lisp	2006/05/24 20:38:54	1.2
+++ /project/cells/cvsroot/Celtk/layout.lisp	2006/06/07 22:13:41	1.3
@@ -27,7 +27,7 @@
 This parent is ~a, kids-packing ~a" self (list .parent (type-of .parent)) (kids-packing .parent)))
   ;
   ; This use next of the parent instead of self is pretty tricky. It has to do with getting
-  ; the pack commands out nested widgets before parents. The pack command issued on behalf
+  ; the pack commands out with nested widgets pacing before parents. The pack command issued on behalf
   ; of a top frame is sorted on the parent. Now we have to pack the top frame. If we associate
   ; the command with the frame, the sort is a tie and either might go first. So we continue
   ; the theme and associate /this/ pack with this top frame's parent. Note that we cannot go the
@@ -59,80 +59,3 @@
         (loop for config in rows
               for idx upfrom 0
               do (tk-format `(:grid ,self) (format nil "grid rowconfigure ~a ~a ~a" (^path) idx config)))))))
-
-;;; --- Layout ------------
-
-(eval-when (compile load eval)
-  (export '( b-left b-top b-right b-bottom b-width b-height
-             l-bounds l-left l-top l-right l-left l-top l-right l-bottom l-width l-height
-             p-offset ^p-offset p-bounds ^p-bounds p-left p-top p-right p-bottom
-             make-bounds p-center-vt b-center-vt p-center-hz
-             c-offset c-bounds offset+)))
-
-(defun bounds-offset (b x-y)
-  (destructuring-bind (x y) x-y
-    (vector (+ (svref b 0) x)
-      (+ (svref b 1) y)
-      (+ (svref b 2) x)
-      (+ (svref b 3) y))))
-
-(defun c-offset (self)
-  (assert (typep self 'item-geometer)() "~a is not typep item-geomete. Type is ~a" self (type-of self))
-  (if (or (null .parent) (typep .parent 'canvas))
-      (eko (nil "c-offset at top" self (type-of self) .parent)
-        (progn
-          (unless .parent (break "no parent for ~a?!" self))
-          #+not (when (and (null .parent)(typep self 'mathx::mx-theq))
-            (break))
-          (^p-offset)))
-    (offset+ (p-offset self) (c-offset .parent))))
-
-(defun c-bounds (self) ;; make this a slot?
-  (assert (typep self 'item))
-  (bounds-offset (l-bounds self) (c-offset self)))
-
-(defmacro b-left (b) `(svref ,b 0))
-(defmacro b-top (b) `(svref ,b 1))
-(defmacro b-right (b) `(svref ,b 2))
-(defmacro b-bottom (b) `(svref ,b 3))
-(defun b-width (b) (- (b-right b) (b-left b)))
-(defun b-height (b) (- (b-bottom b) (b-top b)))
-
-(defmacro l-left (mx) `(b-left (l-bounds ,mx)))
-(defmacro l-top (mx) `(b-top (l-bounds ,mx)))
-(defmacro l-right (mx) `(b-right (l-bounds ,mx)))
-(defmacro l-bottom (mx) `(b-bottom (l-bounds ,mx)))
-(defun l-center-vt (self)
-  (floor (+ (l-top self)(l-bottom self)) 2))
-
-(defun l-width (mx) (b-width (l-bounds mx)))
-(defun l-height (mx) (b-height (l-bounds mx)))
-
-(defmacro p-left (mx) `(b-left (p-bounds ,mx)))
-(defmacro p-top (mx) `(b-top (p-bounds ,mx)))
-(defmacro p-right (mx) `(b-right (p-bounds ,mx)))
-(defmacro p-bottom (mx) `(b-bottom (p-bounds ,mx)))
-
-(defun make-bounds (left top right bottom)
-  (vector left top right bottom))
-
-(defun p-center-vt (self)
-  (b-center-vt (p-bounds self)))
-
-(defun b-center-vt (b)
-  (floor (+ (b-bottom b)(b-top b)) 2))
-
-(defun p-center-hz (self)
-  (b-center-hz (p-bounds self)))
-
-(defun b-center-hz (b)
-  (floor (+ (b-left b)(b-right b)) 2))
-
-(defun offset+ (off1 off2)
-  (mapcar '+ off1 off2))
-
-
-
-
-
-
--- /project/cells/cvsroot/Celtk/load.lisp	2006/05/26 17:50:36	1.8
+++ /project/cells/cvsroot/Celtk/load.lisp	2006/06/07 22:13:41	1.9
@@ -1,25 +1,34 @@
 ;;;
 ;;; 
-;;; First, grab these:
+;;; 1. Grab these:
 ;;;
 ;;;    http://common-lisp.net/cgi-bin/viewcvs.cgi/cells/?root=cells
 ;;;    Celtk: http://common-lisp.net/cgi-bin/viewcvs.cgi/Celtk/?root=cells
 ;;;    CFFI: http://common-lisp.net/project/cffi/releases/cffi_0.9.1.tar.gz
 ;;;    cl-opengl: http://common-lisp.net/cgi-bin/darcsweb/darcsweb.cgi?r=cl-opencl%20cl-opengl;a=summary 
 ;;
-;;; At the bottom of any of those pages look for a "Download tarball" link. Except cl-opengl, those guys
-;;; are not download-friendly.
+;;;   At the bottom of any of those pages look for a "Download tarball" link. Except cl-opengl, those guys
+;;;   are not download-friendly.
 ;;;
-;;; Next, get ASDF loaded:
+;;; 2. Get ASDF loaded. From http://www.cliki.net/asdf we learn:
+;;;
+;;; "If you have SBCL, OpenMCL, ECL or ACL, it's bundled and you need only (require 'asdf). 
+;;;  If you have Debian or Gentoo and the Common Lisp Controller installed, you also 
+;;;  already have it. Otherwise you can find it in the Sourceforge cCLan CVS repository:
+;;;
+;;;     http://cclan.cvs.sourceforge.net/cclan/asdf/ "
+;;;
+;;; 3. If the automatic options in step 2 could not be used, adjust the path and evaluate
+
+#+adjust-pathname-first!
 
-#+eval-this-if-you-do-not-autoload-asdf
 (load (make-pathname #+lispworks :host #-lispworks :device "c"
         :directory '(:absolute "0dev" "cells")
         :name "asdf"
         :type "lisp"))
 
-;;; /After/ you have manually evaluated the above form, you can tell ASDF
-;;; where you put everything by adjusting these paths and evaluating:
+;;; 4. Only after you have gotten ASDF loaded, you can tell ASDF
+;;;    where you put everything by adjusting these paths and evaluating:
 
 (progn
   (push (make-pathname #+lispworks :host #-lispworks :device "c"
@@ -27,14 +36,21 @@
         asdf:*central-registry*)
 
   (push (make-pathname #+lispworks :host #-lispworks :device "c"
-                       :directory '(:absolute "1-devtools" "cffi"))
+                       :directory '(:absolute "1-devtools" "cffi-060606"))
         asdf:*central-registry*)
 
   (push (make-pathname #+lispworks :host #-lispworks :device "c"
                        :directory '(:absolute "0dev" "Celtk"))
         asdf:*central-registry*))
 
-;;; and now you can try building the whole mess:
+;;; 5. Track down all the define-foreign-library calls in the source
+;;;    and fix the pathnames to point to your shared libraries. Recently these were:
+;;;
+;;;    In tk-interp.lisp, Tcl and Tk d-f-ls.
+
+;;; 6. Now you can try building the whole mess. Warning: I use ":serial t" to work around
+;;;    silly ASDF default behavior, so if you start fiddling with the code you may not want
+;;;    to use ASDF to build (or comment out the :serial option until the next session):
 
 (ASDF:OOS 'ASDF:LOAD-OP :celtk)
 
@@ -42,16 +58,30 @@
 
 (ctk::test-window 'celtk-user::lotsa-widgets)
 
-;;; When that crashes, track down all the define-foreign-library calls in the source
-;;; and fix the pathnames to point to your shared libraries.
-
-;;; To see the OpenGL Gears demo:
+;;; To see the OpenGL Gears demo, some heavy lifting is required.
+;;;
+;;; 1. Get, install, and test Togl. Here is a Web link:
+;;;
+;;;       http://www.mesa3d.org/brianp/sig97/togl.htm
+;;;
+;;;    If you are on win32 and have trouble, send an email to the list and I will send you a DLL
+;;;
+;;; 2. You already grabbed cl-opengl from the location shown above. Now:
+;;;
 
+#+adjust-pathname-and-evaluate
 (push (make-pathname #+lispworks :host #-lispworks :device "c"
-                       :directory '(:absolute "1-devtools" "cl-opengl"))
-        asdf:*central-registry*)
+        :directory '(:absolute "1-devtools" "cl-opengl"))
+  asdf:*central-registry*)
+
+;;;
+;;;  3.  Adjust the pathname again in togl.lisp, in the define-foreign-library for Togl.
+;;;
+;;;  4.  Build:
 
 (ASDF:OOS 'ASDF:LOAD-OP :gears)
 
+;;; 5.  Test:
+
 #+test
 (gears::gears)
--- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp	2006/05/24 20:38:54	1.3
+++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp	2006/06/07 22:13:41	1.4
@@ -16,6 +16,7 @@
 
 |#
 
+
 (in-package :celtk-user)
 
 (defmodel lotsa-widgets (window)
--- /project/cells/cvsroot/Celtk/ltktest-ci.lisp	2006/05/25 07:12:59	1.7
+++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp	2006/06/07 22:13:41	1.8
@@ -82,7 +82,7 @@
   ; at just the right time in the larger scheme of state propagation one needs for 
   ; data integrity. What is that scheme?
   ;
-  ; Data integrity: when the overall Cells data model gets perturbed by imperative code -- typically an
+  ; Data integrity: when the overall Cells data model gets perturbed by imperative code -- typically in an
   ; event loop -- executing a SETF of some datapoint X, we want these requirements met:
   ;
   ;   - recompute all and (for efficiency) only state computed off X (directly or indirectly through some intermediate datapoint);
@@ -119,6 +119,7 @@
 ; which operates on the outside world via observers (on-change callbacks) triggered
 ; automatically by the Cells engine. See DEFOBSERVER.
 
+
 (defmodel ltktest-cells-inside (window)
   ()
   
--- /project/cells/cvsroot/Celtk/multichoice.lisp	2006/05/24 20:38:54	1.9
+++ /project/cells/cvsroot/Celtk/multichoice.lisp	2006/06/07 22:13:41	1.10
@@ -65,6 +65,7 @@
     :event-handler (lambda (self xe)
                      (case (tk-event-type (xsv type xe))
                        (:virtualevent
+                        (trc ":virtualevent" (xsv name xe))
                         (case (read-from-string (string-upcase (xsv name xe)))
                           (ListboxSelect
                            (let ((selection (parse-integer (tk-eval "~a curselection" (^path)))))
--- /project/cells/cvsroot/Celtk/run.lisp	2006/06/03 12:04:37	1.15
+++ /project/cells/cvsroot/Celtk/run.lisp	2006/06/07 22:13:41	1.16
@@ -153,9 +153,8 @@
         (^on-name (read-from-string (format nil "^ON-~a" name))))
     `(progn
        (defmethod ,do-on-name (self &rest args)
-         (bIf (cmd (,^on-name))
-           (apply cmd self args)
-           (format t "~&Warning: Target widget ~a has no ~a to run" self ',do-on-name))
+         (bwhen (cmd (,^on-name))
+           (apply cmd self args))
          0)
 
        (defcallback ,do-on-name :int ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer))
@@ -176,16 +175,3 @@
 (defcommand key-up)
 (defcommand key-down)
 
-;;;(defcallback do-on-command :int ((client-data :pointer)(interp :pointer)(argc :int)(argv :pointer))
-;;;  (declare (ignore client-data))
-;;;  (let ((*tki* interp)
-;;;        (args (loop for argn upfrom 1 below argc
-;;;            collecting (mem-aref argv :string argn))))
-;;;    (bif (self (gethash (car args) (dictionary *tkw*)))
-;;;        (apply 'do-on-command self (rest args))
-;;;        (progn
-;;;          (break "do-on-command> Target widget ~a does not exist" path)
-;;;          #+anyvalue? (tcl-set-result interp
-;;;            (format nil "do-on-command> Target widget ~a does not exist" path)
-;;;            (null-pointer))
-;;;          1)))))
\ No newline at end of file
--- /project/cells/cvsroot/Celtk/scroll.lisp	2006/05/24 20:38:54	1.3
+++ /project/cells/cvsroot/Celtk/scroll.lisp	2006/06/07 22:13:41	1.4
@@ -21,7 +21,6 @@
 
 ; --- scroll bars ----------------------------------------
 
-
 (deftk scrollbar (widget)
   ()
   (:tk-spec scrollbar
--- /project/cells/cvsroot/Celtk/tk-interp.lisp	2006/06/03 12:04:37	1.14
+++ /project/cells/cvsroot/Celtk/tk-interp.lisp	2006/06/07 22:13:41	1.15
@@ -33,7 +33,6 @@
   (:unix "libtk.so")
   (t (:default "libtk")))
 
-
 (defctype tcl-retcode :int)
 
 (defcenum tcl-retcode-values
--- /project/cells/cvsroot/Celtk/tk-object.lisp	2006/06/03 12:04:37	1.5
+++ /project/cells/cvsroot/Celtk/tk-object.lisp	2006/06/07 22:13:41	1.6
@@ -35,6 +35,8 @@
 (defmethod md-awaken :before ((self tk-object))
   (make-tk-instance self))
 
+(defmethod parent-path ((self tk-object)) (path self))
+
 ;;; --- deftk --------------------
 
 (defmacro deftk (class superclasses
--- /project/cells/cvsroot/Celtk/tk-structs.lisp	2006/06/03 12:04:37	1.5
+++ /project/cells/cvsroot/Celtk/tk-structs.lisp	2006/06/07 22:13:41	1.6
@@ -120,6 +120,8 @@
 (defmacro xsv (slot-name xptr)
   `(foreign-slot-value ,xptr 'X-Virtual-Event ',slot-name))
 
+(defun myx (xe)
+  (xsv x xe))
 (defmacro xke (slot-name xptr)
   `(foreign-slot-value ,xptr 'x-key-event ',slot-name))
 
--- /project/cells/cvsroot/Celtk/widget.lisp	2006/06/03 12:04:37	1.12
+++ /project/cells/cvsroot/Celtk/widget.lisp	2006/06/07 22:13:41	1.13
@@ -55,8 +55,8 @@
    (xwin :cell nil :accessor xwin :initform nil)
    (packing :reader packing :initarg :packing :initform nil)
    (gridding :reader gridding :initarg :gridding :initform nil)
-   (x :reader x :initarg :x :initform nil)
-   (y :reader y :initarg :y :initform nil)
+   (px :reader px :initarg :px :initform nil)
+   (py :reader py :initarg :py :initform nil)
    (relx :reader relx :initarg :relx :initform nil)
    (rely :reader rely :initarg :rely :initform nil)
    (enabled :reader enabled :initarg :enabled :initform t)
@@ -71,6 +71,9 @@
     :event-handler nil #+debug (lambda (self xe)
                                  (TRC "widget-event-handler" self (tk-event-type (xsv type xe))))))
 
+(eval-when (compile load eval)
+  (export '()))
+
 (defun tk-create-event-handler-ex (widget callback-name &rest masks)
   (let ((self-tkwin (widget-to-tkwin widget)))
     (assert (not (null-pointer-p self-tkwin)))
@@ -113,11 +116,11 @@
 ;;;      "place ~a ~a -relx ~a -rely ~a" (if old-value "configure" "")
 ;;;      (^path) new-value (^rely))))
 
-(defobserver x ((self widget))
+(defobserver px ((self widget))
   (when new-value
     (tk-format `(:grid ,self)
       "place ~a ~a -x ~a -y ~a" (if old-value "configure" "")
-      (^path) new-value (^y))))
+      (^path) new-value (^py))))
 
 (defcallback widget-event-handler-callback :void  ((client-data :pointer)(xe :pointer))
   (let ((self (tkwin-widget client-data)))
@@ -159,6 +162,8 @@
              decorations ^decorations)))
 
 (defmodel item-geometer () ;; mix-in
+  ()
+  #+vestigial?
   ((canvas-offset :initarg :canvas-offset :accessor canvas-offset
      :initform (c_? (eko (nil "standard canvas offset" self (type-of self) (^p-offset))
                      (c-offset self))))
@@ -184,7 +189,7 @@
    (coords-tweak :initarg :coords-tweak :initform '(0 0) :accessor coords-tweak
      :documentation "Text items need this to get positioned according to baseline")
    (coords :initarg :coords :accessor coords
-     :initform (c_? (eko (nil "final coords" self (anchor self)(^l-coords)(^canvas-offset)(^coords-tweak))
+     :initform nil #+old (c_? (eko (nil "final coords" self (anchor self)(^l-coords)(^canvas-offset)(^coords-tweak))
                      (loop for coord-xy = (^l-coords) then (cddr coord-xy)
                          while coord-xy
                          nconcing (mapcar '+ coord-xy (^canvas-offset) (^coords-tweak))))))



From ktilton at common-lisp.net  Wed Jun  7 22:13:42 2006
From: ktilton at common-lisp.net (ktilton)
Date: Wed,  7 Jun 2006 18:13:42 -0400 (EDT)
Subject: [cells-cvs] CVS Celtk/gears
Message-ID: <20060607221342.0CCA0232B4@common-lisp.net>

Update of /project/cells/cvsroot/Celtk/gears
In directory clnet:/tmp/cvs-serv13881/gears

Modified Files:
	gears.lisp 
Log Message:
Resurrect under Lispworks

--- /project/cells/cvsroot/Celtk/gears/gears.lisp	2006/05/26 17:50:36	1.1
+++ /project/cells/cvsroot/Celtk/gears/gears.lisp	2006/06/07 22:13:41	1.2
@@ -35,10 +35,10 @@
                (mk-stack (:packing (c?pack-self "-side left -fill both"))
                  (mk-label :text "Click and drag to rotate image")
                  (mk-row ()
-                         (mk-label :text "Spin delay (ms):")
-                         (mk-entry :id :vtime
-                           :md-value (c-in "10"))
-                         (mk-button-ex (" Quit " (tk-eval "destroy ."))))
+                   (mk-label :text "Spin delay (ms):")
+                   (mk-entry :id :vtime
+                     :md-value (c-in "100"))
+                   (mk-button-ex (" Quit " (tk-eval "destroy ."))))
                  (make-instance 'gears
                    :fm-parent *parent*
                    :width 400 :height 400
@@ -46,12 +46,15 @@
                                          (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0)))))
                    :double 1 ;; "yes"
                    :event-handler (c? (lambda (self xe)
+                                        (trc nil "togl event" (tk-event-type (xsv type xe)))
                                         (case (tk-event-type (xsv type xe))
                                           (:virtualevent
-                                           (trc "canvas virtual" (xsv name xe)))
+                                           (trc nil "canvas virtual" (xsv name xe)))
                                           (:buttonpress
+                                           #+not (RotStart self (xsv x xe) (xsv y xe))
                                            (RotStart self (xsv x-root xe) (xsv y-root xe)))
                                           (:motionnotify
+                                           #+not (RotMove self (xsv x xe) (xsv y xe))
                                            (RotMove self (xsv x-root xe) (xsv y-root xe)))
                                           (:buttonrelease
                                            (setf *startx* nil)))))))))))
@@ -64,10 +67,12 @@
 
 (defun RotMove (self x y)
   (when *startx*
+    (trc nil "rotmove started" x *startx* *xangle0*)
     (setf *xangle* (+ *xangle0* (- x *startx*)))
     (setf *yangle* (+ *yangle0* (- y *starty*)))
     (setf (rotx self) *xangle*)
-    (setf (roty self) *yangle*)))
+    (setf (roty self) *yangle*)
+    (togl-post-redisplay (togl-ptr self))))
 
 (defconstant +pif+ (coerce pi 'single-float))
 
@@ -76,7 +81,7 @@
    (roty :initform (c-in 25) :accessor roty :initarg :roty)
    (rotz :initform (c-in 10) :accessor rotz :initarg :rotz)
    (gear1 :initarg :gear1 :accessor gear1
-     :initform (c_? (trc "making list!!!!! 1")
+     :initform (c_? (trc nil "making list!!!!! 1")
                  (let ((dl (gl:gen-lists 1)))
                    (gl:with-new-list (dl :compile)
                      (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0))
@@ -105,7 +110,7 @@
 (defmethod togl-timer-using-class ((self gears))
   (trc nil "enter gear timer" self (togl-ptr self) (get-internal-real-time))
   (incf (^angle) 5.0)
-  (Togl_PostRedisplay (togl-ptr self))
+  (togl-post-redisplay (togl-ptr self))
   ;(loop until (zerop (ctk::Tcl_DoOneEvent 2)))
   )
 
@@ -117,14 +122,14 @@
   (truc self))
 
 (defmethod togl-reshape-using-class ((self gears)) 
-  (trc "reshape")
+  (trc nil "reshape")
   (truc self t)
   )
 
 (defun truc (self &optional truly)
-  (let ((width (Togl_width (togl-ptr self)))
-        (height (Togl_height (togl-ptr self))))
-    (trc "enter gear reshape" self width (width self))
+  (let ((width (Togl-width (togl-ptr self)))
+        (height (Togl-height (togl-ptr self))))
+    (trc nil "enter gear reshape" self width (width self))
     (gl:viewport 0 (- height (height self)) (width self) (height self))
     (unless truly
       (gl:matrix-mode :projection)
@@ -139,7 +144,7 @@
 
 (defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo))))
   (declare (ignorable scale))
-  
+  (trc nil "display angle" (^rotx)(^roty)(^rotz))
   (gl:clear-color 0 0 0 1)
   (gl:clear :color-buffer-bit :depth-buffer-bit)
   
@@ -163,7 +168,7 @@
       (gl:rotate (- (* -2 (^angle)) 25) 0 0 1)
       (gl:call-list (^gear3))))
   
-  (Togl_SwapBuffers (togl-ptr self))
+  (Togl-Swap-Buffers (togl-ptr self))
   
   #+shhh (print-frame-rate self))
 



From ktilton at common-lisp.net  Fri Jun  9 17:21:35 2006
From: ktilton at common-lisp.net (ktilton)
Date: Fri,  9 Jun 2006 13:21:35 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060609172135.9C7002B02A@common-lisp.net>

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

Modified Files:
	cells-manifesto.txt constructors.lisp propagate.lisp 
Log Message:
Small fix to c-formula to &allow-other-keys, in support of new tutorial.

--- /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/07 22:12:55	1.4
+++ /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/09 17:21:35	1.5
@@ -1,16 +1,76 @@
-
+In the text that follows, [xxx] signifies a footnote named "xxx" and
+listed alphabetically at the end.
                                 
-Cells In A Nutshell
--------------------
-The Cells library as it stands is all about doing interesting things with slots of CLOS instances.
-Nothing says a global variable could not be mediated by a Cell, and indeed one Cells user is 
-known to have experimented with that. Also, some work was done on having slots of DEFSTRUCTs mediated
-by Cells. But for the rest of this exposition let's just talk about CLOS slots and instances.
+Summary
+-------
+Cells is a mature, stable extension to CLOS[impl] allowing one to create classes 
+whose instances can have slot values determined by instance-specific formulas. 
+
+Motivation
+----------
+As a child I watched my father toil at home for hours over paper 
+spreadsheets with pencil and slide rule. After he changed one value, 
+he had to propagate that change to other cells by first remembering 
+which other ones included the changed cell in their computation. 
+Then he had to do the calculations for those, erase, enter...
+and then repeating that process to propagate those changes in a 
+cascade across the paper.
+
+VisiCalc let my father take the formula he had in mind and 
+put it in (declare it to) the electronic spreadsheet. Then VisiCalc 
+could do the tedious work: recalculating, knowing what to recalculate, 
+and knowing in what order to recalculate.
+
+Cells do for programmers what electronic spreadsheets did for my father.
+Without Cells, CLOS slots are like cells of a paper spreadsheet. 
+A single key-down event can cause a cascade of change throughout an 
+application. The programmer has to arrange for it all to happen,
+all in the right order: delete any selected text, insert 
+the new character, re-wrap the text, update the undo mechanism, revisit
+the menu statuses ("Cut" is no longer enabled), update the scroll bars,
+possibly scroll the window, flag the file as unsaved... 
+
+Here is a real-world case study:
+
+"The last company I worked with made a product that was a control unit
+for some mechanical devices, presenting both sensor readings coming in
+from those devices and an interface to program the devices. Consider
+it like a very sophisticated microwave oven, perhaps with a
+temperature probe.
+
+"The UI code was a frighteningly complex rat's nest. Input data
+arriving from the sensors changed certain state values, which caused
+the display to update, but the system state also changed, and rules
+had to be evaluated, the outcome of which might be tuning to the
+running job or warning messages presented to the user, and in the
+meantime the user may be adjusting the running job. I'm sure there are
+even more interactions I'm leaving out.
+
+"There was no "large idea" in this code to organize these dependencies
+or orchestrate the data flow. The individual facilities were
+well-formed enough: "message" input and output, GUI widgets and forms,
+real-world entities modeled as entities in the code. However, the
+connections between these things were ad-hoc and not formalized. Every
+change to the system would provoke defects, and the failure usually
+involved not propagating some event, propagating it at the wrong time,
+or propagating it to the wrong recipients."
+   --- Steven Harris, on comp.lang.lisp
+
+What Mr. Harris describes is what Fred Brooks [bullet] said was an essential
+property of software development, meaning by essential that there was no
+way around it, and thus his prediction that a software silver bullet was
+in principle impossible.
+
+Which brings us to Cells.
 
 DEFMODEL and Slot types
 -----------------------
 Classes, some of whose slots may be mediated by Cells, are defined by DEFMODEL, which is exactly
-like DEFCLASS but adds support for two slot definition options, :cell and :unchanged-if.
+like DEFCLASS but adds support for two slot definition options, :cell and :unchanged-if. Classes 
+defined by DEFMODEL can inherit from normal CLOS classes.
+
+New slot definition options
+----------------------------
 
    :cell {nil | t | :ephemeral}
 
@@ -36,8 +96,8 @@
 
 Cell types
 ----------
-The Cells library allows the programmer to specify at make-instance time that a slot of an instance
-be mediated for the life of that instance by one of:
+The Cells library allows the programmer to specify at make-instance time that a Cell 
+slot of an instance be mediated for the life of that instance by one of:
 
    -- a so-called "input" Cell;
    -- a "ruled" Cell; or
@@ -94,7 +154,7 @@
 
 Observers
 ---------
-To allow the emergent data animation model to operate usefully on the world outside the model--if only to
+To allow the emergent animated data model to operate usefully on the world outside the model--if only to
 update the screen--programmers may specify so-called observer callbacks dispatched according to: slot name, 
 instance, new value, old value, and whether the old value actually existed (false only on the first go).
 
@@ -141,12 +201,33 @@
 
 Greater object re-use. Slots of instances can be authored with rules, not just literal values. In a sense,
 we get greater reuse by allowing instances to override slot derivations instance by instance. But not slot
-expressions, which are still class-oriented.
+expressions, which are still class-oriented. By this I mean the observers expressing changes in value are 
+dispatched by the class of the instance and so are not instance-specific. (Such a thing has been 
+suggested, however.) Another strong bit of class-orientation comes from the fact that code reading
+slot X of some instance Y obviously does so without knowing how the returned value was derived. It knows 
+only that the slot is named X, and will do things with that value assuming only that it has the
+X attribute of the instance Y. So again: the derivation of a slot value is potentially instance-oriented 
+under Cells, but its expression or manifestation is still class-oriented.
+
+Natural decomposition of overall application complexity into so many simple rules and slot observers. 
+Let's return for a moment to VisiCalc and its descendants. In even the most complex financial spreadsheet  
+model, no one cell rule accesses more than a relatively few other spreadsheet cells (counting a row or 
+column range as one reference). Yet the complex model emerges. All the work of tracking dependencies
+is handled by the spreadsheet software, which require no special declaration by the modeller. They simply 
+writes the Cell rule. In writing the rule, they are concerned only with the derivation of one datapoint from
+a population of other datapoints. No effort goes into arranging for the rule to get run at the right time,
+and certainly no energy is spent worrying about what other cells might be using the authored cell. That
+cell has certain semantics -- "account balance", perhaps -- and the modeller need only worry about writing
+a correct, static computation of those semantics.
+
+Same with Cells. :) The only difference is that VisiCalc has one "observer" requirement for all cells: 
+update the screen. In Cells applications, a significant amount of application functionality -- indeed, all
+its outputs -- end up in cell observers. But as discussed above, this additional burden falls only on 
+the class designer when they decide to add a slot to a class. As instances are created and different rules
+specified for different slots to achieve custom behavior, the effort is the same as for the VisiCalc user.
 
-Natural decomposition of overall application complexity into so many simple rules and slot observers.
-
-Applications
-------------
+Suggested Applications
+----------------------
 Any application that must maintain an interesting, long-lived data model incorporating a stream of unpredictable 
 data. Two examples: any GUI application and a RoboCup soccer client.
 
@@ -157,14 +238,10 @@
 
 Prior Art
 ---------
-The entire constraint programming field, beginning I guess with Guy Steele's
-PhD Thesis in which he develops a constraint programming language or two:
-  http://portal.acm.org/citation.cfm?id=889490&dl=ACM&coll=ACM
-  http://www.cs.utk.edu/~bvz/quickplan.html
+Adobe Adam, originally developed only to manage complex GUIs. [Adam]
 
-Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963.
-Steele himself cites Sketchpad as inexlicably unappreciated prior
-art to his Constraints system:
+COSI, a class-based Cells-alike used at STSCI to in software used to 
+schedule Hubble telescope viewing time. [COSI]
 
 Garnet's KR: http://www.cs.cmu.edu/~garnet/
 Also written in Lisp. Cells looks  much like KR, though Cells was 
@@ -172,32 +249,14 @@
 an astonishing number of backdoors to its constraint
 engine, none of which have turned out to be necessary for Cells.
 
-COSI:
- "The Constraint Sequencing Infrastructure (COSI) is an extension to
-the Common Lisp Object System (*(CLOS)) which supports a constraint
-based object-oriented programming model. .....
-
-"A constraint is a specialized method which will be automatically
-re-run by the COSI infrastructure whenever any of its input values
-change. Input values are any of the object attributes that are
-accessed by the constraint, and which are therefore assumed to
-alter the processing within the constraint. 
-
-"Whenever a state change occurs those constraints which depend upon
-that state are added to a propagation queue. When the system is
-queried a propagation cycle runs ensuring that the state of the
-system is consistent with all constraints prior to returning a value."
--- http://www.cliki.net/ACL2/COSI?source
+The entire constraint programming field, beginning I guess with Guy Steele's
+PhD Thesis in which he develops a constraint programming language or two:
+  http://portal.acm.org/citation.cfm?id=889490&dl=ACM&coll=ACM
+  http://www.cs.utk.edu/~bvz/quickplan.html
 
-Adobe Adam:
-http://opensource.adobe.com/group__asl__overview.html#asl_overview_intro_to_adam_and_eve
-"Adam is a modeling engine and declarative language for describing constraints and 
-relationships on a collection of values, typically the parameters to an 
-application command. When bound to a human interface (HI) Adam provides 
-the logic that controls the HI behavior. Adam is similar in concept to a spreadsheet 
-or a forms manager. Values are set and dependent values are recalculated. 
-Adam provides facilities to resolve interrelated dependencies and to track 
-those dependencies, beyond what a spreadsheet provides."
+Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963.
+Steele himself cites Sketchpad as inexlicably unappreciated prior
+art to his Constraints system:
 
 See also:
  The spreadsheet paradigm: http://www.cs.utk.edu/~bvz/active-value-spreadsheet.html
@@ -260,8 +319,9 @@
 deferred until all computed cells are up-to-date with the current state of 
 the universe."
 
-Uncommentary
-------------
+_______________
+Uncommentary :)
+
 -- Peter Seibel, comp.lang.lisp:
 "I couldn't find anything that explained what it was and why I should care."
 
@@ -270,4 +330,46 @@
 interesting, but I haven't downloaded it yet, and I haven't
 checked out how it works or what /exactly/ it does."
 
-                                
\ No newline at end of file
+_________                      
+Footnotes
+
+[Adam] "Adam is a modeling engine and declarative language for describing constraints and 
+relationships on a collection of values, typically the parameters to an 
+application command. When bound to a human interface (HI) Adam provides 
+the logic that controls the HI behavior. Adam is similar in concept to a spreadsheet 
+or a forms manager. Values are set and dependent values are recalculated. 
+Adam provides facilities to resolve interrelated dependencies and to track 
+those dependencies, beyond what a spreadsheet provides."
+http://opensource.adobe.com/group__asl__overview.html#asl_overview_intro_to_adam_and_eve
+________
+[bullet] This resolves a problem Fred Brooks identified in 1987: ""The essence of a software 
+entity is a construct of  interlocking concepts: data sets, relationships among data items, algorithms, 
+and invocations of functions... Software systems have orders-of-magnitude more states than 
+computers do...a scaling-up of a software  entity is not merely a repetition of the same elements 
+in larger sizes; it is necessarily an increase in the number of different elements. In most cases, 
+the elements interact with each other in some nonlinear fashion, and the complexity of the whole 
+increases much more than linearly."
+-- http://www.virtualschool.edu/mon/SoftwareEngineering/BrooksNoSilverBullet.html
+______
+[COSI] "The Constraint Sequencing Infrastructure (COSI) is an extension to
+the Common Lisp Object System (*(CLOS)) which supports a constraint
+based object-oriented programming model. .....
+
+"A constraint is a specialized method which will be automatically
+re-run by the COSI infrastructure whenever any of its input values
+change. Input values are any of the object attributes that are
+accessed by the constraint, and which are therefore assumed to
+alter the processing within the constraint. 
+
+"Whenever a state change occurs those constraints which depend upon
+that state are added to a propagation queue. When the system is
+queried a propagation cycle runs ensuring that the state of the
+system is consistent with all constraints prior to returning a value."
+-- http://www.cliki.net/ACL2/COSI?source
+______
+[impl] The Cells library as it stands is all about doing interesting things 
+with slots of CLOS instances, but Cells is not only about CLOS or even Lisp. 
+One Cells user is known to have mediated a global variable with a Cell, some work 
+was done on having slots of DEFSTRUCTs mediated by Cells, and ports to C++, Java, and
+Python have been explored.
+
--- /project/cells/cvsroot/cells/constructors.lisp	2006/05/20 06:32:19	1.6
+++ /project/cells/cvsroot/cells/constructors.lisp	2006/06/09 17:21:35	1.7
@@ -93,7 +93,7 @@
                   ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag)))
                   ,result))))))
 
-(defmacro c-formula ((&rest keys &key lazy) &body forms)
+(defmacro c-formula ((&rest keys &key lazy &allow-other-keys) &body forms)
   (assert (member lazy '(nil t :once-asked :until-asked :always)))
   `(make-c-dependent
     :code ',forms
--- /project/cells/cvsroot/cells/propagate.lisp	2006/06/05 00:01:22	1.14
+++ /project/cells/cvsroot/cells/propagate.lisp	2006/06/09 17:21:35	1.15
@@ -165,7 +165,7 @@
       (with-integrity (:tell-dependents c)
         (assert (null *c-calculators*))
         (let ((*causation* causation))
-          (trc "c-propagate-to-users > notifying users of" c (mapcar 'c-slot-name (c-users c)))
+          (trc nil "c-propagate-to-users > notifying users of" c (mapcar 'c-slot-name (c-users c)))
           (dolist (user (c-users c))
             (unless (member (cr-lazy user) '(t :always :once-asked))
               (trc nil "propagating to user is (used,user):" c user)



From ktilton at common-lisp.net  Fri Jun  9 17:21:35 2006
From: ktilton at common-lisp.net (ktilton)
Date: Fri,  9 Jun 2006 13:21:35 -0400 (EDT)
Subject: [cells-cvs] CVS cells/gui-geometry
Message-ID: <20060609172135.D7F9D2E1AB@common-lisp.net>

Update of /project/cells/cvsroot/cells/gui-geometry
In directory clnet:/tmp/cvs-serv8778/gui-geometry

Modified Files:
	defpackage.lisp 
Log Message:
Small fix to c-formula to &allow-other-keys, in support of new tutorial.

--- /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp	2006/06/05 00:01:22	1.2
+++ /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp	2006/06/09 17:21:35	1.3
@@ -17,8 +17,9 @@
 (defpackage #:gui-geometry
   (:nicknames #:geo)
   (:use #:common-lisp #:utils-kt #:cells)
-  (:export #:geometer #:geo-zero-tl #:geo-inline
+  (:export #:geometer #:geo-zero-tl #:geo-inline #:a-stack #:a-row
     #:px #:py #:ll #:lt #:lr #:lb
+    #:^px #:^py #:^ll #:^lt #:^lr #:^lb
     #:u96ths #:udots #:uinches #:uin #:upoints #:upts #:u8ths #:u16ths #:u32nds
     #:mkr #:v2-move #:l-height #:mkv2 #:^offset-within #:inset-lr #:v2-v #:v2-h
     #:r-bounds 
@@ -29,34 +30,23 @@
     #:collapsed 
     #:g-box 
     #:v2-in-rect-ratio 
-    #:v2-xlate 
-    #:v2-in-rect 
-    #:v2-add 
-    #:v2-subtract 
+    #:v2-xlate #:v2-in-rect #:v2-add #:v2-subtract 
     #:log2scr 
     #:^lr-width 
     #:px-maintain-pr 
     #:outset 
     #:py-maintain-pb 
     #:cs-logical-dpi 
-    #:px-maintain-pl 
-    #:py-maintain-pt 
+    #:px-maintain-pl #:py-maintain-pt 
     #:scr2log 
-    #:inset-width 
-    #:inset-height 
+    #:inset-width #:inset-height 
     #:res-to-res 
     #:logical-to-screen-point 
     #:nres-to-res 
     #:cs-logical-screen-resolution 
     #:outl 
-    #:with-r-bounds 
-    #:r-inset 
+    #:with-r-bounds #:r-inset 
     #:ncopy-rect 
     #:l 
-    #:r-height 
-    #:r-width 
-    #:r-top 
-    #:r-right 
-    #:r-bottom 
-    #:r-left 
+    #:r-height #:r-width #:r-top #:r-right #:r-bottom #:r-left 
     #:l-width ))



From ktilton at common-lisp.net  Fri Jun  9 17:21:36 2006
From: ktilton at common-lisp.net (ktilton)
Date: Fri,  9 Jun 2006 13:21:36 -0400 (EDT)
Subject: [cells-cvs] CVS cells/tutorial
Message-ID: <20060609172136.204343000F@common-lisp.net>

Update of /project/cells/cvsroot/cells/tutorial
In directory clnet:/tmp/cvs-serv8778/tutorial

Modified Files:
	tutorial.lpr 
Added Files:
	04-formula-once-then-input.lisp 
Log Message:
Small fix to c-formula to &allow-other-keys, in support of new tutorial.

--- /project/cells/cvsroot/cells/tutorial/tutorial.lpr	2006/05/30 02:47:45	1.1
+++ /project/cells/cvsroot/cells/tutorial/tutorial.lpr	2006/06/09 17:21:35	1.2
@@ -12,7 +12,9 @@
                                 "01b-change-handling.lisp")
                  (make-instance 'module :name "01c-cascade.lisp")
                  (make-instance 'module :name "02-lesson.lisp")
-                 (make-instance 'module :name "03-ephemeral.lisp"))
+                 (make-instance 'module :name "03-ephemeral.lisp")
+                 (make-instance 'module :name
+                                "04-formula-once-then-input.lisp"))
   :projects (list (make-instance 'project-module :name "..\\cells"))
   :libraries nil
   :distributed-files nil

--- /project/cells/cvsroot/cells/tutorial/04-formula-once-then-input.lisp	2006/06/09 17:21:36	NONE
+++ /project/cells/cvsroot/cells/tutorial/04-formula-once-then-input.lisp	2006/06/09 17:21:36	1.1


(defpackage #:tu-rule-once-then-input (:use :cl :utils-kt :cells :tu-cells))
(in-package #:tu-rule-once-then-input)


#|

Often in interactive applications one needs to do interesting things to come up
with an initial value for a field which then is to be edited by a user, or
for some other reason regularly fed as a C-INPUT.

|#

(defvar *db-entry*)

(defun get-age (id)
  (bwhen (props (cdr (assoc id *db-entry* :test 'string=)))
    (getf props :age)))

(defmodel kenny-view ()
  ((age :accessor age :initform (c-formula (:inputp t)
                                  (- (get-age "555-55-5555")
                                    (^grecian-formula-amt))))
   (grecian-formula-amt :accessor grecian-formula-amt
      :initform (c-in 5))))

(defobserver age ((self kenny-view))
  (setf (getf (cdr (assoc "555-55-5555" *db-entry* :test 'string=)) :age) new-value))

#+test
(let ((*db-entry* (copy-list '(("555-55-5555" . (:name "ken" :age 54))
               ("666-66-6666" . (:name "satan" :age most-positive-fixnum))))))
  (cells-reset)
  (let ((kv (make-instance 'kenny-view)))
    (print `(:age-init ,(age kv)))
    (assert (= 49 (age kv)))

    (incf (grecian-formula-amt kv) 10) ;; try looking younger
    (assert (= 15 (grecian-formula-amt kv)))

    (assert (= 49 (age kv))) ;; unchanged -- the age rule is gone

    (print `(:happy-birthday ,(incf (age kv))))
    (assert (= 50 (age kv)(get-age "555-55-5555")))
    ;
    ; just showin' off...
    (assert (= 51 (1+ (age kv))(incf (age kv))(get-age "555-55-5555")))))




From ktilton at common-lisp.net  Sat Jun 10 22:16:35 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sat, 10 Jun 2006 18:16:35 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060610221635.B444C4E006@common-lisp.net>

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

Modified Files:
	cell-types.lisp cells.lisp md-slot-value.lisp 
	optimization.lisp 
Log Message:
Most interesting, sloght change to md-slot-value-assume, to abort unchanged assignment a whisker sooner.

--- /project/cells/cvsroot/cells/cell-types.lisp	2006/05/20 06:32:19	1.9
+++ /project/cells/cvsroot/cells/cell-types.lisp	2006/06/10 22:16:35	1.10
@@ -103,40 +103,6 @@
   (usage (make-array 16 :element-type 'bit
                         :initial-element 0) :type simple-bit-vector))
 
-
-(defstruct (c-stream
-            (:include c-dependent)
-            (:conc-name cs-))
-  values)
-
-(defstruct streamer from stepper donep to)
-
-#+(or)
-(defmacro c~~~ (&key (from 0)
-                 stepper
-                 (donep (c-lambda (> .cache (streamer-to slot-c))))
-                 to)
-   `(make-c-stream
-     :rule (c-lambda (make-streamer
-                      :from ,from
-                      :stepper ,stepper
-                      :to ,to :donep ,donep))))
-
-;;;(defmethod md-slot-value-assume :around ((c c-stream) (s streamer))
-;;;  (bif (to (streamer-to s))
-;;;    (loop for slot-value = (streamer-from s)
-;;;          then (bif (stepper (streamer-stepper s))
-;;;                 (funcall stepper c)
-;;;                 (incf slot-value))
-;;;          until (bif (to (streamer-to s))
-;;;                  (> slot-value to)
-;;;                  (bwhen (donep-test (streamer-donep s))
-;;;                    (funcall donep-test c)))
-;;;          do (progn
-;;;               (print `(assume doing ,slot-value))
-;;;               (call-next-method c slot-value))))
-;;;  (c-optimize-away?! c))
-
 (defstruct (c-drifter
             (:include c-dependent)))
 
--- /project/cells/cvsroot/cells/cells.lisp	2006/06/03 00:38:04	1.11
+++ /project/cells/cvsroot/cells/cells.lisp	2006/06/10 22:16:35	1.12
@@ -81,7 +81,8 @@
 (define-symbol-macro .cause
     (car *causation*))
 
-(define-condition unbound-cell (unbound-slot) ())
+(define-condition unbound-cell (unbound-slot)
+  ((cell :initarg :cell :reader cell :initform nil)))
 
 (defgeneric slot-value-observe (slotname self new old old-boundp)
   #-(or cormanlisp)
--- /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/07 22:12:55	1.17
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/10 22:16:35	1.18
@@ -70,7 +70,7 @@
    (t (c-pulse-update c :valid-uninfluenced)))
 
   (when (c-unboundp c)
-    (error 'unbound-cell :instance (c-model c) :name (c-slot-name c)))
+    (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c)))
 
   (c-value c))
 
@@ -141,7 +141,7 @@
           (without-c-dependency
               (c-propagate c prior-value t)))))))
 
-;;; --- setf md-slot-value --------------------------------------------------------
+;;; --- setf md.slot.value --------------------------------------------------------
 ;;;
 
 (defun (setf md-slot-value) (new-value self slot-name
@@ -176,35 +176,33 @@
       (let ((prior-state (c-value-state c))
             (prior-value (c-value c))
             (absorbed-value (c-absorb-value c raw-value)))
-        
+
+        (c-pulse-update c :slotv-assume)
+
+        ; --- head off unchanged; this got moved earlier on 2006-06-10 ---
+        (when (and (not (eq propagation-code :propagate))
+                (eql prior-state :valid)
+                (c-no-news c absorbed-value prior-value))
+          (trc nil "(setf md-slot-value) > early no news" propagation-code prior-state prior-value  absorbed-value)
+          (count-it :nonews)
+          (return-from md-slot-value-assume absorbed-value))
+
         ; --- slot maintenance ---
         (unless (c-synaptic c)
           (md-slot-value-store (c-model c) (c-slot-name c) absorbed-value))
         
         ; --- cell maintenance ---
-        (c-pulse-update c :slotv-assume)
         (setf
          (c-value c) absorbed-value
          (c-value-state c) :valid
          (c-state c) :awake)
         
-        (unless (typep c 'c-stream) ;; c-stream (actually a FNYI) needs to run out first stream at least
-          (c-optimize-away?! c)) ;;; put optimize test here to avoid needless linking
-        
+        (c-optimize-away?! c) ;;; put optimize test here to avoid needless linking
         
         ; --- data flow propagation -----------
-        ;
-        (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 (not (eq propagation-code :propagate))
-                (eql prior-state :valid)
-                (c-no-news c absorbed-value prior-value)))
-            (progn
-              (trc nil "(setf md-slot-value) >no news" prior-state (c-no-news c absorbed-value prior-value))
-              (count-it :nonews))
-          (progn
-            (setf (c-changed c) t)
-            (c-propagate c prior-value (eq prior-state :valid))))  ;; until 06-02-13 was (not (eq prior-state :unbound))
+        (unless (eq propagation-code :no-propagate)
+          (setf (c-changed c) t)
+          (c-propagate c prior-value (eq prior-state :valid)))  ;; until 06-02-13 was (not (eq prior-state :unbound))
         
         absorbed-value)))
 
--- /project/cells/cvsroot/cells/optimization.lisp	2006/05/20 06:32:19	1.6
+++ /project/cells/cvsroot/cells/optimization.lisp	2006/06/10 22:16:35	1.7
@@ -27,7 +27,7 @@
   (typecase c
     (c-dependent
      (if (and *c-optimizep*
-           (not (c-optimized-away-p c)) ;; c-streams come this way repeatedly even if optimized away
+           (not (c-optimized-away-p c)) ;; c-streams (FNYI) may come this way repeatedly even if optimized away
            (c-validp c)
            (not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around)
            ;; chop (every (lambda (lbl-syn) (null (cd-useds (cdr lbl-syn)))) (cd-synapses c))



From ktilton at common-lisp.net  Sat Jun 10 22:16:35 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sat, 10 Jun 2006 18:16:35 -0400 (EDT)
Subject: [cells-cvs] CVS cells/cells-test
Message-ID: <20060610221635.D304D4E003@common-lisp.net>

Update of /project/cells/cvsroot/cells/cells-test
In directory clnet:/tmp/cvs-serv7851/cells-test

Modified Files:
	cells-test.lpr 
Log Message:
Most interesting, sloght change to md-slot-value-assume, to abort unchanged assignment a whisker sooner.

--- /project/cells/cvsroot/cells/cells-test/cells-test.lpr	2006/05/12 08:27:39	1.5
+++ /project/cells/cvsroot/cells/cells-test/cells-test.lpr	2006/06/10 22:16:35	1.6
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (May 5, 2006 15:39)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 



From ktilton at common-lisp.net  Sat Jun 10 22:16:36 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sat, 10 Jun 2006 18:16:36 -0400 (EDT)
Subject: [cells-cvs] CVS cells/tutorial
Message-ID: <20060610221636.2BE184E003@common-lisp.net>

Update of /project/cells/cvsroot/cells/tutorial
In directory clnet:/tmp/cvs-serv7851/tutorial

Modified Files:
	04-formula-once-then-input.lisp 
Log Message:
Most interesting, sloght change to md-slot-value-assume, to abort unchanged assignment a whisker sooner.

--- /project/cells/cvsroot/cells/tutorial/04-formula-once-then-input.lisp	2006/06/09 17:21:35	1.1
+++ /project/cells/cvsroot/cells/tutorial/04-formula-once-then-input.lisp	2006/06/10 22:16:36	1.2
@@ -45,6 +45,4 @@
     (assert (= 50 (age kv)(get-age "555-55-5555")))
     ;
     ; just showin' off...
-    (assert (= 51 (1+ (age kv))(incf (age kv))(get-age "555-55-5555")))))
-
-
+    (assert (= 51 (1+ (age kv))(incf (age kv))(get-age "555-55-5555")))))
\ No newline at end of file



From ktilton at common-lisp.net  Sun Jun 11 13:31:32 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sun, 11 Jun 2006 09:31:32 -0400 (EDT)
Subject: [cells-cvs] CVS Celtk
Message-ID: <20060611133132.81B5674181@common-lisp.net>

Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv31274

Modified Files:
	Celtk.lisp frame.lisp togl.lisp widget.lisp 
Log Message:


--- /project/cells/cvsroot/Celtk/Celtk.lisp	2006/06/07 22:13:41	1.30
+++ /project/cells/cvsroot/Celtk/Celtk.lisp	2006/06/11 13:31:32	1.31
@@ -16,7 +16,7 @@
 
 |#
 
-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.30 2006/06/07 22:13:41 ktilton Exp $
+;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.31 2006/06/11 13:31:32 ktilton Exp $
 
 (defpackage :celtk
   (:nicknames "CTK")
@@ -135,7 +135,7 @@
       (let ((yes '())
             (no  '("font")))
         (declare (ignorable yes no))
-        (when (and (or ;; (null yes)
+        (when t #+not (and (or ;; (null yes)
                      (find-if (lambda (s) (search s tk$)) yes))
                 (not (find-if (lambda (s) (search s tk$)) no)))
           (format t "~&tk> ~a~%" tk$)))
@@ -178,7 +178,7 @@
   ; all this just to display "[". Unsolved is how we will
   ; send a text label with a string /containing/ the character #\[
   ;
-  (trc "tk-send-value" c (char-code c) (format nil "\"\\~3,'0o\"" (char-code c)))
+  (trc nil "tk-send-value" c (char-code c) (format nil "\"\\~3,'0o\"" (char-code c)))
   (format nil "\"\\~3,'0o\"" (char-code c)))
 
 (defmethod tk-send-value (other)
--- /project/cells/cvsroot/Celtk/frame.lisp	2006/05/24 20:38:54	1.2
+++ /project/cells/cvsroot/Celtk/frame.lisp	2006/06/11 13:31:32	1.3
@@ -20,7 +20,7 @@
 
 ;--- group geometry -----------------------------------------
 
-(defmodel inline-mixin (composite-widget)
+(defmodel inline-mixin (composite-widget widget)
   ((padx :initarg :padx :accessor padx :initform 0)
    (pady :initarg :pady :accessor pady :initform 0)
    (packing-side :initarg :packing-side :accessor packing-side :initform 'left)
@@ -55,7 +55,7 @@
 
 ;--- f r a m e --------------------------------------------------
 
-(deftk frame (composite-widget)
+(deftk frame (composite-widget widget)
   ()
   (:tk-spec frame -borderwidth -cursor	-highlightbackground -highlightcolor
     -highlightthickness -padx -pady -relief
--- /project/cells/cvsroot/Celtk/togl.lisp	2006/06/03 12:04:37	1.9
+++ /project/cells/cvsroot/Celtk/togl.lisp	2006/06/11 13:31:32	1.10
@@ -71,7 +71,7 @@
 ;; Togl_DumpToEpsFile
 
 (eval-when (compile load eval)
-  (export '(togl-swap-buffers togl-post-redisplay togl-ptr togl-reshape-func
+  (export '(with-togl togl-interp togl-swap-buffers togl-post-redisplay togl-ptr togl-reshape-func
              togl togl-timer-using-class togl-post-redisplay togl-reshape-using-class
              togl-display-using-class togl-width togl-height togl-create-using-class)))
 
@@ -148,6 +148,13 @@
     :id (gentemp "TOGL")
     :ident (c? (^path))))
 
+(defmacro with-togl ((togl-form width-var height-var) &body body &aux (togl-ptr (gensym)))
+  `(let* ((,togl-ptr (togl-ptr ,togl-form))
+          (*tki* (togl-interp ,togl-ptr))
+          (,width-var (togl-width ,togl-ptr))
+          (,height-var (togl-height ,togl-ptr)))
+     , at body))
+
 (defmacro def-togl-callback (root (&optional (ptr-var 'togl-ptr)(self-var 'self)) &body preamble)
   (let ((register$ (format nil "TOGL-~a-FUNC" root))
         (cb$ (format nil "TOGL-~a" root))
@@ -183,18 +190,6 @@
   (with-integrity (:client `(:make-tk ,self))
     (setf (gethash (^path) (dictionary .tkw)) self)
     (tk-format-now "togl ~a ~{~(~a~) ~a~^ ~}"
-      (path self)(tk-configurations self)))) ;; this leads to "togl <path> [-<config option> <value]*", in turn to togl_create
-
+      (path self)(tk-configurations self))))
+ ;; this leads to "togl <path> [-<config option> <value]*", in turn to togl_create
 
-;;;
-;;;(DEFCFUN ("Togl_DestroyFunc" TOGL-DESTROY-FUNC) :VOID (CALLBACK :POINTER))
-;;;(defcallback togl-destroy :void ((togl-ptr :pointer))
-;;;  (trc "togl-destroy ptr" togl-ptr (loop for k being the hash-keys of (tkwins *tkw*)
-;;;                                         collecting k))
-;;;  (unless (c-stopped)
-;;;    (let ((self (or (gethash (pointer-address togl-ptr) (tkwins *tkw*)) (gethash (togl-ident togl-ptr) (dictionary *tkw*)))))
-;;;      
-;;;      (togl-destroy-using-class self))))
-;;;(DEFMETHOD TOGL-DESTROY-USING-CLASS :AROUND ((SELF TOGL))
-;;;  (IF (CB-DESTROY SELF) (FUNCALL (CB-DESTROY SELF) SELF) (CALL-NEXT-METHOD)))
-;;;(DEFMETHOD TOGL-DESTROY-USING-CLASS ((SELF TOGL)))
\ No newline at end of file
--- /project/cells/cvsroot/Celtk/widget.lisp	2006/06/07 22:13:41	1.13
+++ /project/cells/cvsroot/Celtk/widget.lisp	2006/06/11 13:31:32	1.14
@@ -47,10 +47,10 @@
 
 (defmodel widget (family tk-object)
   ((path :accessor path :initarg :path
-     :initform (c? (trc nil "path calc" self (parent-path (fm-parent self)) (md-name self))
-                 (format nil "~(~a.~a~)"
-                     (parent-path (fm-parent self))
-                     (md-name self))))
+     :initform (c? (eko (nil "path" self (parent-path (fm-parent self))(md-name self))
+                     (format nil "~(~a.~a~)"
+                       (parent-path (fm-parent self))
+                       (md-name self)))))
    (tkwin :cell nil :accessor tkwin :initform nil)
    (xwin :cell nil :accessor xwin :initform nil)
    (packing :reader packing :initarg :packing :initform nil)
@@ -110,17 +110,12 @@
     (tkwin-register self)
     (tk-create-event-handler-ex self 'widget-event-handler-callback -1)))
 
-;;;(defobserver relx ()
-;;;  (when new-value
-;;;    (tk-format `(:grid ,self)
-;;;      "place ~a ~a -relx ~a -rely ~a" (if old-value "configure" "")
-;;;      (^path) new-value (^rely))))
-
 (defobserver px ((self widget))
-  (when new-value
-    (tk-format `(:grid ,self)
-      "place ~a ~a -x ~a -y ~a" (if old-value "configure" "")
-      (^path) new-value (^py))))
+  (unless (typep self 'window)
+    (when new-value
+      (tk-format `(:grid ,self) ;; placing is like grid for this sort
+        "place ~a ~a -x ~a -y ~a" (if old-value "configure" "")
+        (^path) new-value (^py)))))
 
 (defcallback widget-event-handler-callback :void  ((client-data :pointer)(xe :pointer))
   (let ((self (tkwin-widget client-data)))



From ktilton at common-lisp.net  Tue Jun 13 05:05:14 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue, 13 Jun 2006 01:05:14 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060613050514.60B89232B7@common-lisp.net>

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

Modified Files:
	cell-types.lisp family.lisp initialize.lisp md-slot-value.lisp 
	md-utilities.lisp model-object.lisp propagate.lisp 
	synapse.lisp 
Log Message:
Mostly make ephemerals more transparent by always rerunning rules of dependents. This is actually a bug fix, at some profound level of understanding beyond me.

--- /project/cells/cvsroot/cells/cell-types.lisp	2006/06/10 22:16:35	1.10
+++ /project/cells/cvsroot/cells/cell-types.lisp	2006/06/13 05:05:12	1.11
@@ -64,10 +64,14 @@
     ; within finish-business we are sure all users have been recalculated
     ; and all outputs completed.
     ;
+    ; ;; good q: what does (setf <ephem> 'x) return? historically nil, but...?
+    ;
     (with-integrity (:ephemeral-reset c)
       (trc nil "!!!!!!!!!!!!!! c-ephemeral-reset resetting:" c)
       (md-slot-value-store (c-model c) (c-slot-name c) nil)
-      (setf (c-value c) nil)))) ;; good q: what does (setf <ephem> 'x) return? historically nil, but...?
+      (setf (c-value c) nil)
+      (loop for user in (c-users c)
+            do (calculate-and-link user)))))
 
 ; -----------------------------------------------------
 
--- /project/cells/cvsroot/cells/family.lisp	2006/05/20 06:32:19	1.7
+++ /project/cells/cvsroot/cells/family.lisp	2006/06/13 05:05:12	1.8
@@ -135,8 +135,8 @@
             (multiple-value-bind (c-or-value suppressp)
                 (funcall (ks-rule ks-def) self)
               (unless suppressp
-                (trc nil "c-install " slot-name c-or-value)
-                (c-install self slot-name c-or-value)))))))))
+                (trc nil "md-install-cell " slot-name c-or-value)
+                (md-install-cell self slot-name c-or-value)))))))))
 
 (defobserver .kids ((self family) new-kids old-kids)
   (declare (ignorable usage))
--- /project/cells/cvsroot/cells/initialize.lisp	2006/05/20 06:32:19	1.5
+++ /project/cells/cvsroot/cells/initialize.lisp	2006/06/13 05:05:12	1.6
@@ -24,11 +24,10 @@
 (defstruct (c-envaluer (:conc-name nil))
   envalue-rule)
 
-
-(defmethod c-awaken-cell (c)
+(defmethod awaken-cell (c)
   (declare (ignorable c)))
 
-(defmethod c-awaken-cell ((c cell))
+(defmethod awaken-cell ((c cell))
   (assert (c-inputp c))
   ;
   ; nothing to calculate, but every cellular slot should be output
@@ -36,17 +35,17 @@
   (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil)
   (c-ephemeral-reset c))
 
-(defmethod c-awaken-cell ((c c-ruled))
+(defmethod awaken-cell ((c c-ruled))
   (let (*c-calculators*)
-    (c-calculate-and-set c)))
+    (calculate-and-set c)))
 
 #+cormanlisp ; satisfy CormanCL bug
-(defmethod c-awaken-cell ((c c-dependent))
+(defmethod awaken-cell ((c c-dependent))
   (let (*c-calculators*)
-    (trc nil "c-awaken-cell c-dependent clearing *c-calculators*" c)
-    (c-calculate-and-set c)))
+    (trc nil "awaken-cell c-dependent clearing *c-calculators*" c)
+    (calculate-and-set c)))
 
-(defmethod c-awaken-cell ((c c-drifter))
+(defmethod awaken-cell ((c c-drifter))
   ;
   ; drifters *begin* valid, so the derived version's test for unbounditude
   ; would keep (drift) rule ever from being evaluated. correct solution
@@ -55,7 +54,7 @@
   ; awakening, because awakening's other role is to get an instance up to speed
   ; at once upon instantiation 
   ;
-  (c-calculate-and-set c)
+  (calculate-and-set c)
   (cond ((c-validp c) (c-value c))
         ((c-unboundp c) nil)
         (t "illegal state!!!")))
--- /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/10 22:16:35	1.18
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/13 05:05:12	1.19
@@ -42,14 +42,14 @@
   (if c
       (prog1
           (with-integrity ()
-            (c-value-ensure-current c))
+            (ensure-value-is-current c))
         (when (car *c-calculators*)
           (c-link-ex c)))
     (values (bd-slot-value self slot-name) nil)))
   
-(defun c-value-ensure-current (c)
-  (count-it :c-value-ensure-current)
-  (trc nil "c-value-ensure-current >" c)
+(defun ensure-value-is-current (c)
+  (count-it :ensure-value-is-current)
+  (trc nil "ensure-value-is-current >" c)
   (cond
    ((c-currentp c)(trc nil "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete
    ;; and then get reset here (ie, ((c-input-p c) (c-ephemeral-reset c))). ie, do not assume inputs are never obsolete
@@ -58,14 +58,14 @@
 
    ((or (not (c-validp c))
       (some (lambda (used)
-              (c-value-ensure-current used)
+              (ensure-value-is-current used)
               (trc nil "comparing pulses (user, used): " (c-pulse c)(c-pulse used))
               (when (and (c-changed used) (> (c-pulse used)(c-pulse c)))
                  (trc nil "used changed" c used)
                 t))
         (cd-useds c)))
     (trc nil "ensuring current calc-set of" (c-slot-name c) debug-id)
-    (c-calculate-and-set c))
+    (calculate-and-set c))
 
    (t (c-pulse-update c :valid-uninfluenced)))
 
@@ -74,37 +74,36 @@
 
   (c-value c))
 
-(defun c-calculate-and-set (c)
+(defun calculate-and-set (c)
   (flet ((body ()
            (when (c-stopped)
              (princ #\.)
-             (return-from c-calculate-and-set))
-    
+             (return-from calculate-and-set))
+           
            (when (find c *c-calculators*) ;; circularity
-             (trc "c-calculate-and-set breaking on circularity" c)
              (c-break ;; break is problem when testing cells on some CLs
               "cell ~a midst askers: ~a" c *c-calculators*))
-           (trc nil "calcing, calcers" (c-slot-name c) (mapcar 'c-slot-name *c-calculators*))
-           (count-it :c-calculate-and-set)
-           ;;;  (count-it :c-calculate-and-set (type-of (c-model c))) ;; (c-slot-name c))
-    
-           (cd-usage-clear-all c)
-    
+  
            (multiple-value-bind (raw-value propagation-code)
-               (let ((*c-calculators* (cons c *c-calculators*))
-                     (*defer-changes* t))
-                 (funcall (cr-rule c) c))
+               (calculate-and-link c)
+             
              (when (and *c-debug* (typep raw-value 'cell))
                (c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))"
                  c raw-value))
-        
-             (c-unlink-unused c)
-             (trc nil "calc-set calling md-sv-assum" c propagation-code)
+             
              (md-slot-value-assume c raw-value propagation-code))))
     (if nil ;; *dbg*
         (ukt::wtrc (0 100 "calcnset" c) (body))
       (body))))
 
+(defun calculate-and-link (c)
+  (let ((*c-calculators* (cons c *c-calculators*))
+        (*defer-changes* t))
+    (cd-usage-clear-all c)
+    (multiple-value-prog1
+        (funcall (cr-rule c) c)
+      (c-unlink-unused c))))
+
 ;-------------------------------------------------------------
 
 (defun md-slot-makunbound (self slot-name
@@ -183,7 +182,7 @@
         (when (and (not (eq propagation-code :propagate))
                 (eql prior-state :valid)
                 (c-no-news c absorbed-value prior-value))
-          (trc nil "(setf md-slot-value) > early no news" propagation-code prior-state prior-value  absorbed-value)
+          (trc "(setf md-slot-value) > early no news" propagation-code prior-state prior-value  absorbed-value)
           (count-it :nonews)
           (return-from md-slot-value-assume absorbed-value))
 
--- /project/cells/cvsroot/cells/md-utilities.lisp	2006/05/20 06:32:19	1.4
+++ /project/cells/cvsroot/cells/md-utilities.lisp	2006/06/13 05:05:13	1.5
@@ -67,6 +67,6 @@
 
 (defmacro make-kid (class &rest initargs)
   `(make-instance ,class
-     :fm-parent self
+     :fm-parent (progn (assert self) self)
      , at initargs))
 
--- /project/cells/cvsroot/cells/model-object.lisp	2006/05/20 06:32:19	1.5
+++ /project/cells/cvsroot/cells/model-object.lisp	2006/06/13 05:05:13	1.6
@@ -51,7 +51,7 @@
                  (slot-value self sn))
       when (typep sv 'cell)
       do (if (md-slot-cell-type (type-of self) sn)
-             (c-install self sn sv)
+             (md-install-cell self sn sv)
            (when *c-debug*
              (trc "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv self sn))))
   ;
@@ -60,12 +60,12 @@
   (with-integrity (:awaken self)
     (md-awaken self)))
 
-(defun c-install (self sn c &aux (c-isa-cell (typep c 'cell)))
+(defun md-install-cell (self sn c &aux (c-isa-cell (typep c 'cell)))
   ;
   ; iff cell, init and move into dictionary
   ;
   (when c-isa-cell
-    (count-it :c-install)
+    (count-it :md-install-cell)
     (setf
      (c-model c) self
      (c-slot-name c) sn
@@ -121,7 +121,7 @@
          ((not c)
           ;; all slots must hit any change handlers as instances come into existence to get
           ;; models fully connected to the outside world they are controlling. that
-          ;; happens in c-awaken-cell for slots in fact mediated by cells, but as an
+          ;; happens in awaken-cell for slots in fact mediated by cells, but as an
           ;; optimization we allow raw literal values to be specified for a slot, in
           ;; which case heroic measures are needed to get the slot to the change handler
           ;;
@@ -142,7 +142,7 @@
           (count-it :c-awaken)
                 
           (setf (c-state c) :awake)
-          (c-awaken-cell c))))))
+          (awaken-cell c))))))
   
   (setf (md-state self) :awake)
   self)
--- /project/cells/cvsroot/cells/propagate.lisp	2006/06/09 17:21:35	1.15
+++ /project/cells/cvsroot/cells/propagate.lisp	2006/06/13 05:05:13	1.16
@@ -46,7 +46,7 @@
 
 (defun c-pulse-update (c key)
   (declare (ignorable key))
-  (trc nil  "c-pulse-update updating" *data-pulse-id* c key)
+  (trc nil "c-pulse-update updating" *data-pulse-id* c key)
   (setf (c-changed c) nil
       (c-pulse c) *data-pulse-id*))
 
@@ -159,8 +159,8 @@
   ;         but B is busy eagerly propagating. "This time" is important because it means
   ;         there is no way one can reliably be sure H will not ask for A
   ;
-  (trc nil "c-propagate-to-users > queueing" c)
   (when (c-users c)
+    (trc nil "c-propagate-to-users > queueing" c)
     (let ((causation (cons c *causation*))) ;; in case deferred
       (with-integrity (:tell-dependents c)
         (assert (null *c-calculators*))
@@ -169,7 +169,7 @@
           (dolist (user (c-users c))
             (unless (member (cr-lazy user) '(t :always :once-asked))
               (trc nil "propagating to user is (used,user):" c user)
-              (c-value-ensure-current user))))))))
+              (ensure-value-is-current user))))))))
 
 
 
--- /project/cells/cvsroot/cells/synapse.lisp	2006/05/20 06:32:19	1.10
+++ /project/cells/cvsroot/cells/synapse.lisp	2006/06/13 05:05:13	1.11
@@ -40,7 +40,7 @@
        (prog1
            (multiple-value-bind (v p)
                (with-integrity ()
-                 (c-value-ensure-current synapse))
+                 (ensure-value-is-current synapse))
              (trc nil "with-synapse: synapse, v, prop" synapse v p)
              (values v p))
          (c-link-ex synapse)))))



From ktilton at common-lisp.net  Tue Jun 13 05:05:17 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue, 13 Jun 2006 01:05:17 -0400 (EDT)
Subject: [cells-cvs] CVS cells/cells-test
Message-ID: <20060613050517.4B70824010@common-lisp.net>

Update of /project/cells/cvsroot/cells/cells-test
In directory clnet:/tmp/cvs-serv7503/cells-test

Modified Files:
	test.lisp 
Log Message:
Mostly make ephemerals more transparent by always rerunning rules of dependents. This is actually a bug fix, at some profound level of understanding beyond me.

--- /project/cells/cvsroot/cells/cells-test/test.lisp	2006/05/30 02:47:45	1.5
+++ /project/cells/cvsroot/cells/cells-test/test.lisp	2006/06/13 05:05:14	1.6
@@ -72,7 +72,12 @@
 (defun test-cells ()
   (loop for test in (reverse *cell-tests*)
         do (cell-test-init test)
-        (funcall test)))
+        (funcall test))
+  (print (make-string 40 :initial-element #\*))
+  (print (make-string 40 :initial-element #\*))
+  (print "*** Cells-test successfully completed **")
+  (print (make-string 40 :initial-element #\*))
+  (print (make-string 40 :initial-element #\*)))
 
 (defun cell-test-init (name)
   (print (make-string 40 :initial-element #\!))



From ktilton at common-lisp.net  Tue Jun 13 05:05:17 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue, 13 Jun 2006 01:05:17 -0400 (EDT)
Subject: [cells-cvs] CVS cells/tutorial
Message-ID: <20060613050517.A376828044@common-lisp.net>

Update of /project/cells/cvsroot/cells/tutorial
In directory clnet:/tmp/cvs-serv7503/tutorial

Modified Files:
	tutorial.lpr 
Log Message:
Mostly make ephemerals more transparent by always rerunning rules of dependents. This is actually a bug fix, at some profound level of understanding beyond me.

--- /project/cells/cvsroot/cells/tutorial/tutorial.lpr	2006/06/09 17:21:35	1.2
+++ /project/cells/cvsroot/cells/tutorial/tutorial.lpr	2006/06/13 05:05:17	1.3
@@ -2,7 +2,7 @@
 
 (in-package :cg-user)
 
-(defpackage :COMMON-GRAPHICS-USER)
+(defpackage :TU-CELLS)
 
 (define-project :name :tutorial
   :modules (list (make-instance 'module :name "test.lisp")
@@ -14,12 +14,16 @@
                  (make-instance 'module :name "02-lesson.lisp")
                  (make-instance 'module :name "03-ephemeral.lisp")
                  (make-instance 'module :name
-                                "04-formula-once-then-input.lisp"))
+                                "04-formula-once-then-input.lisp")
+                 (make-instance 'module :name "05-class-cell.lisp")
+                 (make-instance 'module :name
+                                "..\\gotchas\\some-ephemeral-uhoh.lisp")
+                 (make-instance 'module :name "chat-cells.lisp"))
   :projects (list (make-instance 'project-module :name "..\\cells"))
   :libraries nil
   :distributed-files nil
   :internally-loaded-files nil
-  :project-package-name :common-graphics-user
+  :project-package-name :tu-cells
   :main-form nil
   :compilation-unit t
   :verbose nil
@@ -84,7 +88,7 @@
   :old-space-size 256000
   :new-space-size 6144
   :runtime-build-option :standard
-  :on-initialization 'default-init-function
+  :on-initialization 'tu-cells::tu-some-ephemeral-uhoh
   :on-restart 'do-default-restart)
 
 ;; End of Project Definition



From ktilton at common-lisp.net  Tue Jun 13 05:05:17 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue, 13 Jun 2006 01:05:17 -0400 (EDT)
Subject: [cells-cvs] CVS cells/gui-geometry
Message-ID: <20060613050517.8476624014@common-lisp.net>

Update of /project/cells/cvsroot/cells/gui-geometry
In directory clnet:/tmp/cvs-serv7503/gui-geometry

Modified Files:
	geometer.lisp 
Log Message:
Mostly make ephemerals more transparent by always rerunning rules of dependents. This is actually a bug fix, at some profound level of understanding beyond me.

--- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp	2006/06/05 00:01:22	1.2
+++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp	2006/06/13 05:05:17	1.3
@@ -199,17 +199,17 @@
 
 ;;-----------------------------------------------
 
-(defun inset-width (image)
-   (- (l-width image) (outset image) (outset image)))
+(defun inset-width (self)
+   (- (l-width self) (outset self) (outset self)))
 
-(defun inset-lr (image)
-   (- (lr image) (outset image)))
+(defun inset-lr (self)
+   (- (lr self) (outset self)))
 
-(defun inset-lb (image)
-   (ups (lb image) (outset image)))
+(defun inset-lb (self)
+   (ups (lb self) (outset self)))
 
-(defun inset-height (image)
-   (- (l-height image) (outset image) (outset image)))
+(defun inset-height (self)
+   (- (l-height self) (outset self) (outset self)))
 
 ;---------------------------------
 



From ktilton at common-lisp.net  Tue Jun 13 16:19:35 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue, 13 Jun 2006 12:19:35 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060613161935.73B0D69002@common-lisp.net>

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

Modified Files:
	cell-types.lisp initialize.lisp md-slot-value.lisp 
	model-object.lisp propagate.lisp 
Log Message:
Back out change to ephemerals

--- /project/cells/cvsroot/cells/cell-types.lisp	2006/06/13 05:05:12	1.11
+++ /project/cells/cvsroot/cells/cell-types.lisp	2006/06/13 16:19:35	1.12
@@ -53,11 +53,11 @@
 ; 
 ; Not a type, but an option to the :cell parameter of defmodel
 ;
-(defun c-ephemeral-p (c)
+(defun ephemeral-p (c)
   (eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c))))
 
-(defun c-ephemeral-reset (c)
-  (when (c-ephemeral-p c) ;; so caller does not need to worry about this
+(defun ephemeral-reset (c)
+  (when (ephemeral-p c) ;; so caller does not need to worry about this
     ;
     ; as of Cells3 we defer resetting ephemerals because everything
     ; else gets deferred and we cannot /really/ reset it until
@@ -67,9 +67,10 @@
     ; ;; good q: what does (setf <ephem> 'x) return? historically nil, but...?
     ;
     (with-integrity (:ephemeral-reset c)
-      (trc nil "!!!!!!!!!!!!!! c-ephemeral-reset resetting:" c)
+      (trc nil "!!!!!!!!!!!!!! ephemeral-reset resetting:" c)
       (md-slot-value-store (c-model c) (c-slot-name c) nil)
       (setf (c-value c) nil)
+      #+notsureaboutthis
       (loop for user in (c-users c)
             do (calculate-and-link user)))))
 
--- /project/cells/cvsroot/cells/initialize.lisp	2006/06/13 05:05:12	1.6
+++ /project/cells/cvsroot/cells/initialize.lisp	2006/06/13 16:19:35	1.7
@@ -33,7 +33,7 @@
   ; nothing to calculate, but every cellular slot should be output
   ;
   (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil)
-  (c-ephemeral-reset c))
+  (ephemeral-reset c))
 
 (defmethod awaken-cell ((c c-ruled))
   (let (*c-calculators*)
--- /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/13 05:05:12	1.19
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/13 16:19:35	1.20
@@ -52,7 +52,7 @@
   (trc nil "ensure-value-is-current >" c)
   (cond
    ((c-currentp c)(trc nil "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete
-   ;; and then get reset here (ie, ((c-input-p c) (c-ephemeral-reset c))). ie, do not assume inputs are never obsolete
+   ;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete
    ;;
    ((c-inputp c)(trc nil "c-inputp" c)) ;; always current (for now; see above)
 
--- /project/cells/cvsroot/cells/model-object.lisp	2006/06/13 05:05:13	1.6
+++ /project/cells/cvsroot/cells/model-object.lisp	2006/06/13 16:19:35	1.7
@@ -49,6 +49,7 @@
       for sn = (slot-definition-name esd)
       for sv = (when (slot-boundp self sn)
                  (slot-value self sn))
+      ;;do (print (list self sn sv (typep sv 'cell)))
       when (typep sv 'cell)
       do (if (md-slot-cell-type (type-of self) sn)
              (md-install-cell self sn sv)
--- /project/cells/cvsroot/cells/propagate.lisp	2006/06/13 05:05:13	1.16
+++ /project/cells/cvsroot/cells/propagate.lisp	2006/06/13 16:19:35	1.17
@@ -103,7 +103,7 @@
     ; would this be bad for persistent CLOS, in which a DB would think there was still a link
     ; between two records until the value actually got cleared?
     ;
-    (c-ephemeral-reset c)
+    (ephemeral-reset c)
     ))
 
 ; --- slot change -----------------------------------------------------------



From ktilton at common-lisp.net  Tue Jun 13 16:19:35 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue, 13 Jun 2006 12:19:35 -0400 (EDT)
Subject: [cells-cvs] CVS cells/tutorial
Message-ID: <20060613161935.ABDE375027@common-lisp.net>

Update of /project/cells/cvsroot/cells/tutorial
In directory clnet:/tmp/cvs-serv4640/tutorial

Modified Files:
	tutorial.lpr 
Log Message:
Back out change to ephemerals

--- /project/cells/cvsroot/cells/tutorial/tutorial.lpr	2006/06/13 05:05:17	1.3
+++ /project/cells/cvsroot/cells/tutorial/tutorial.lpr	2006/06/13 16:19:35	1.4
@@ -17,7 +17,7 @@
                                 "04-formula-once-then-input.lisp")
                  (make-instance 'module :name "05-class-cell.lisp")
                  (make-instance 'module :name
-                                "..\\gotchas\\some-ephemeral-uhoh.lisp")
+                                "..\\gotchas\\lost-ephemeral-init.lisp")
                  (make-instance 'module :name "chat-cells.lisp"))
   :projects (list (make-instance 'project-module :name "..\\cells"))
   :libraries nil
@@ -88,7 +88,7 @@
   :old-space-size 256000
   :new-space-size 6144
   :runtime-build-option :standard
-  :on-initialization 'tu-cells::tu-some-ephemeral-uhoh
+  :on-initialization 'tu-cells::tu-chat-2
   :on-restart 'do-default-restart)
 
 ;; End of Project Definition



From ktilton at common-lisp.net  Thu Jun 15 15:55:01 2006
From: ktilton at common-lisp.net (ktilton)
Date: Thu, 15 Jun 2006 11:55:01 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060615155501.29DAC6F242@common-lisp.net>

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

Modified Files:
	md-slot-value.lisp 
Log Message:


--- /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/13 16:19:35	1.20
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/15 15:55:01	1.21
@@ -182,7 +182,7 @@
         (when (and (not (eq propagation-code :propagate))
                 (eql prior-state :valid)
                 (c-no-news c absorbed-value prior-value))
-          (trc "(setf md-slot-value) > early no news" propagation-code prior-state prior-value  absorbed-value)
+          (trc nil "(setf md-slot-value) > early no news" propagation-code prior-state prior-value  absorbed-value)
           (count-it :nonews)
           (return-from md-slot-value-assume absorbed-value))
 



From ktilton at common-lisp.net  Tue Jun 20 14:16:45 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue, 20 Jun 2006 10:16:45 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060620141645.0EB1B1A006@common-lisp.net>

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

Modified Files:
	cell-types.lisp cells-manifesto.txt defmodel.lisp 
	defpackage.lisp link.lisp 
Log Message:


--- /project/cells/cvsroot/cells/cell-types.lisp	2006/06/13 16:19:35	1.12
+++ /project/cells/cvsroot/cells/cell-types.lisp	2006/06/20 14:16:44	1.13
@@ -105,8 +105,11 @@
             (:conc-name cd-))
   ;; chop (synapses nil :type list)
   (useds nil :type list)
-  (usage (make-array 16 :element-type 'bit
-                        :initial-element 0) :type simple-bit-vector))
+  (usage (blank-usage-mask)))
+
+(defun blank-usage-mask ()
+  (make-array 16 :element-type 'bit
+    :initial-element 0))
 
 (defstruct (c-drifter
             (:include c-dependent)))
@@ -153,3 +156,6 @@
 
 (defmethod c-print-value (c stream)
   (declare (ignore c stream)))
+
+
+
--- /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/09 17:21:35	1.5
+++ /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/20 14:16:44	1.6
@@ -126,14 +126,26 @@
 -----------
 Ruled Cells come with an instance-specific  rule in the form of an anonymous function of two variables, 
 the instance owning the slot and the prior value (if any) computed by the rule. These rules consist of 
-arbitrarily complex Common Lisp code, and are invoked immediately after instance initialization or, if 
-they are declared lazy, when their slot readers are invoked. 
+arbitrarily complex Common Lisp code, and are invoked immediately after instance initialization (but see
+the next bit on lazy cells).
 
 When a rule runs, any dynamic read (either expressly in the rule source or during the execution of 
 some function invoked by the rule) of a slot of any instance mediated by a Cell of any type establishes a
 runtime dependency of the ruled cell on the slot of the instance that was read. Note then that thanks
 to code branching, dependencies can vary after every rule invocation.
 
+Lazy Ruled Cells
+----------------
+Laziness is cell-specific, applies only to ruled cells, and comes in four varieties:
+
+     :once-asked -- this will get evaluated and "observed" on initialization, but then not get reevaluated 
+immediately if dependencies change, rather only when read by application code.
+
+     :until-asked  -- this does not get evaluated/observed until read by application code, but then it becomes 
+un-lazy, eagerly reevaluated as soon as any dependency changes (not waiting until asked).
+
+     :always -- not evaluated/observed until read, and not reevaluated until read after a dependency changes. 
+
 Dataflow
 --------
 When application code assigns a new value to an input Cell (a quick way of saying an instance slot mediated by
@@ -157,6 +169,15 @@
 To allow the emergent animated data model to operate usefully on the world outside the model--if only to
 update the screen--programmers may specify so-called observer callbacks dispatched according to: slot name, 
 instance, new value, old value, and whether the old value actually existed (false only on the first go).
+Observers are inherited according to the rules of CLOS class inheritance. If multiple primary observer
+methods apply because of inheritance, they all get run, most specific last.
+
+ie, observers are a GF with PROGN method combination.
+
+Observers get called in two circumstances: as part of Model object initialization, in a processing step 
+just after CLOS instance initialization, and when a slot changes value. Any observer of a Cell slot 
+is guaranteed to be called at least once during intialization even if a cell slot is bound to a constant
+or if it is an input or ruled Cell that never changes value.
 
 It is legal for observer code to assign to input Cells, but (a) special syntax is required to defer executuion
 until the observed state change has fully propagated; and (b) doing so compromises the declarative
@@ -296,20 +317,18 @@
 is called 'defpart' in cells-gtk); and, (b) formula that specify the value of CLOS slots."
 
 -- Phillip Eby, PyCells and peak.events, 
-... http://www.eby-sarna.com/pipermail/peak/2006-May/002545.html
+   http://www.eby-sarna.com/pipermail/peak/2006-May/002545.html
 "What I discovered is quite cool.  The Cells system *automatically 
 discovers* dynamic dependencies, without having to explicitly specify that 
 X depends on Y, as long as X and Y are both implemented using cell 
 objects.  The system knows when you are computing a value for X, and 
 registers the fact that Y was read during this computation, thus allowing 
-it to automatically invalidate the X calculation if Y changes.
-
-"...Aside from the automatic dependency 
-detection, the cells system has another trick that is able to significantly 
-reduce the complexity of event cascades, similar to what I was trying (but 
-failing) to do using the "scheduled thread" concept in peak.events.
-
-"Specifically, the cells system understands how to make event-based updates 
+it to automatically invalidate the X calculation if Y changes....
+Aside from the automatic dependency detection, the cells system has 
+another trick that is able to significantly reduce the complexity of 
+event cascades, similar to what I was trying (but failing) to do using 
+the "scheduled thread" concept in peak.events.
+Specifically, the cells system understands how to make event-based updates 
 orderly and deterministic, in a way that peak.events cannot.  It 
 effectively divides time into "propagation" and "non-propagation" 
 states.  Instead of simply making callbacks whenever a computed value 
--- /project/cells/cvsroot/cells/defmodel.lisp	2006/05/20 06:32:19	1.4
+++ /project/cells/cvsroot/cells/defmodel.lisp	2006/06/20 14:16:44	1.5
@@ -26,98 +26,164 @@
      ;
      ; define slot macros before class so they can appear in initforms and default-initargs
      ;
-     ,@(mapcar (lambda (slotspec)
-                 (destructuring-bind
-                     (slotname &rest slotargs
-                       &key (cell t) (accessor slotname) reader
-                       &allow-other-keys)
-                     slotspec
-
-                   (declare (ignorable slotargs))
-                   (when cell
-                     (let* ((reader-fn (or reader accessor))
-                            (deriver-fn (intern$ "^" (symbol-name reader-fn)))
-                            )
-                       ;
-                       ; may as well do this here...
-                       ;
-                       ;;(trc nil "slot, deriverfn would be" slotname deriverfn)
-                       `(eval-when (:compile-toplevel :execute :load-toplevel)
-                          (setf (md-slot-cell-type ',class ',slotname) ,cell)
-                          (unless (macro-function ',deriver-fn)
-                            (defmacro ,deriver-fn ()
-                              `(,',reader-fn self)))
-                          )
-                       ))
-                   ))
-         slotspecs)
-     
-     ;
-     ; -------  defclass ---------------  (^slot-value ,model ',',slotname)
-     ;
-     
-     (progn
-       (defclass ,class ,(or directsupers '(model-object));; now we can def the class
-               ,(mapcar (lambda (s)
-                          (list* (car s)
-                            (let ((ias (cdr s)))
-                              ;; We handle accessor below
-                              (when (getf ias :cell t)
-                                (remf ias :reader)
-                                (remf ias :writer)
-                                (remf ias :accessor))
-                              (remf ias :cell)
-                              (remf ias :unchanged-if)
-                              ias))) (mapcar #'copy-list slotspecs))
-               (:documentation
-                ,@(or (cdr (find :documentation options :key #'car))
-                    '("chya")))
-               (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
-                   ,@(cdr (find :default-initargs options :key #'car)))
-               (:metaclass ,(or (cadr (find :metaclass options :key #'car))
-                              'standard-class)))
-
-       (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key)
-         (declare (ignore slot-names iargs))
-         ,(when (and directsupers (not (member 'model-object directsupers)))
-            `(unless (typep self 'model-object)
-               (error "If no superclass of ~a inherits directly
+     ,@(loop for slotspec in slotspecs
+           collecting (destructuring-bind
+                          (slotname &rest slotargs
+                            &key (cell t) (accessor slotname) reader
+                            &allow-other-keys)
+                          slotspec
+                        
+                        (declare (ignorable slotargs))
+                        (when cell
+                          (let* ((reader-fn (or reader accessor))
+                                 (deriver-fn (intern$ "^" (symbol-name reader-fn)))
+                                 )
+                            ;
+                            ; may as well do this here...
+                            ;
+                            ;;(trc nil "slot, deriverfn would be" slotname deriverfn)
+                            `(eval-when (:compile-toplevel :execute :load-toplevel)
+                               (setf (md-slot-cell-type ',class ',slotname) ,cell)
+                               (unless (macro-function ',deriver-fn)
+                                 (defmacro ,deriver-fn ()
+                                   `(,',reader-fn self)))
+                               )
+                            ))
+                        ))
+  
+  ;
+  ; -------  defclass ---------------  (^slot-value ,model ',',slotname)
+  ;
+  
+  (progn
+    (defclass ,class ,(or directsupers '(model-object));; now we can def the class
+      ,(mapcar (lambda (s)
+                 (list* (car s)
+                   (let ((ias (cdr s)))
+                     ;; We handle accessor below
+                     (when (getf ias :cell t)
+                       (remf ias :reader)
+                       (remf ias :writer)
+                       (remf ias :accessor))
+                     (remf ias :cell)
+                     (remf ias :unchanged-if)
+                     ias))) (mapcar #'copy-list slotspecs))
+      (:documentation
+       ,@(or (cdr (find :documentation options :key #'car))
+           '("chya")))
+      (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
+          ,@(cdr (find :default-initargs options :key #'car)))
+      (:metaclass ,(or (cadr (find :metaclass options :key #'car))
+                     'standard-class)))
+    
+    (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key)
+      (declare (ignore slot-names iargs))
+      ,(when (and directsupers (not (member 'model-object directsupers)))
+         `(unless (typep self 'model-object)
+            (error "If no superclass of ~a inherits directly
 or indirectly from model-object, model-object must be included as a direct super-class in
 the defmodel form for ~a" ',class ',class))))
-       ;
-       ; slot accessors once class is defined...
-       ;
-       ,@(mapcar (lambda (slotspec)
-                   (destructuring-bind
-                       (slotname &rest slotargs
-                         &key (cell t) unchanged-if (accessor slotname) reader writer type
-                         &allow-other-keys)
-                       slotspec
-
-                     (declare (ignorable slotargs))
-                     (when cell
-                       (let* ((reader-fn (or reader accessor))
-                              (writer-fn (or writer accessor))
-                              )
-                         (setf (md-slot-cell-type class slotname) cell)
+    ;
+    ; slot accessors once class is defined...
+    ;
+    ,@(mapcar (lambda (slotspec)
+                (destructuring-bind
+                    (slotname &rest slotargs
+                      &key (cell t) unchanged-if (accessor slotname) reader writer type
+                      &allow-other-keys)
+                    slotspec
+                  
+                  (declare (ignorable slotargs))
+                  (when cell
+                    (let* ((reader-fn (or reader accessor))
+                           (writer-fn (or writer accessor))
+                           )
+                      (setf (md-slot-cell-type class slotname) cell)
+                      
+                      
+                      `(progn
+                         ,(when reader-fn
+                            `(defmethod ,reader-fn ((self ,class))
+                               (md-slot-value self ',slotname)))
                          
+                         ,(when writer-fn
+                            `(defmethod (setf ,writer-fn) (new-value (self ,class))
+                               (setf (md-slot-value self ',slotname)
+                                 ,(if type
+                                      `(coerce new-value ',type)
+                                    'new-value))))
                          
-                         `(progn
-                            ,(when reader-fn
-                               `(defmethod ,reader-fn ((self ,class))
-                                  (md-slot-value self ',slotname)))
-                            
-                            ,(when writer-fn
-                               `(defmethod (setf ,writer-fn) (new-value (self ,class))
-                                  (setf (md-slot-value self ',slotname)
-                                    ,(if type
-                                         `(coerce new-value ',type)
-                                       'new-value))))
+                         ,(when unchanged-if
+                            `(def-c-unchanged-test (,class ,slotname) ,unchanged-if))
+                         )
+                      ))
+                  ))
+        slotspecs)
+    (find-class ',class))))
+
+(defun defmd-canonicalize-slot (slotname
+                                 &key
+                                 (cell nil cell-p)
+                                 (initform nil initform-p)
+                                 (initarg (intern (symbol-name slotname) :keyword))
+                                 (documentation nil documentation-p)
+                                 (unchanged-if nil unchanged-if-p)
+                                 (reader slotname reader-p)
+                                 (writer `(setf ,slotname) writer-p)
+                                 (accessor slotname accessor-p)
+                                 (allocation nil allocation-p))
+  (list* slotname :initarg initarg
+    (append
+     (when cell-p (list :cell cell))
+     (when initform-p (list :initform initform))
+     (when unchanged-if-p (list :unchanged-if unchanged-if))
+     (when reader-p (list :reader reader))
+     (when writer-p (list :writer writer))
+     (when (or accessor-p 
+             (not (and reader-p writer-p)))
+       (list :accessor accessor))
+     (when allocation-p (list :allocation allocation))
+     (when documentation-p (list :documentation documentation)))))
+
+(defmacro defmd (class superclasses &rest mdspec)
+  `(defmodel ,class ,superclasses
+     ,@(let (definitargs class-options slots)
+         (loop with skip
+             for (spec next) on mdspec
+             if skip
+             do (setf skip nil)
+             else do (etypecase spec
+                       (cons
+                        (cond
+                         ((keywordp (car spec))
+                          (assert (find (car spec) '(:documentation :metaclass)))
+                          (push spec class-options))
+                         ((find (cadr spec) '(:initarg :cell :initform :allocation :reader :writer :accessor :documentation))
+                          (push (apply 'defmd-canonicalize-slot spec) slots))
+                         (t ;; shortform (slotname initform &rest slotdef-key-values)
+                          (push (apply 'defmd-canonicalize-slot
+                                  (list* (car spec) :initform (cadr spec) (cddr spec))) slots))))
+                       (keyword
+                        (setf definitargs (append definitargs (list spec next)))
+                        (setf skip t))
+                       (symbol (push (list spec :initform nil
+                                       :initarg (intern (symbol-name spec) :keyword)
+                                       :accessor spec) slots)))
+             finally
+               (return (list* (nreverse slots)
+                         (delete-if 'null
+                           (list* `(:default-initargs , at definitargs)
+                             (nreverse class-options)))))))))
+
+#+test
+(progn
+  (defclass md-test-super ()())
 
-                            ,(when unchanged-if
-                               `(def-c-unchanged-test (,class ,slotname) ,unchanged-if))
-                            )
-                         ))
-                     ))
-           slotspecs)
-       (find-class ',class))))
+  (defmd defmd-test (md-test-super)
+    (aaa :cell nil :initform nil :initarg :aaa :accessor aaa) ;; defmd would have written the same
+    (aa2 :documentation "hi mom")
+    bbb
+    (ccc 42 :allocation :class)
+    (ddd (c-in nil) :cell :ephemeral)
+    :superx 42 ;; default-initarg
+    (:documentation "as if!")))
\ No newline at end of file
--- /project/cells/cvsroot/cells/defpackage.lisp	2006/05/01 20:23:14	1.6
+++ /project/cells/cvsroot/cells/defpackage.lisp	2006/06/20 14:16:44	1.7
@@ -48,7 +48,7 @@
     #:c-formula #:c? #:c_? #:c?8 #:c?_ #:c??
     #:with-integrity #:without-c-dependency #:self #:*parent*
     #:.cache #:.with-c-cache #:c-lambda
-    #:defmodel #:defobserver #:slot-value-observe #:def-c-unchanged-test
+    #:defmodel #:defmd #:defobserver #:slot-value-observe #:def-c-unchanged-test
     #:new-value #:old-value #:old-value-boundp #:c...
     #:md-awaken
     #:mkpart #:make-kid #:the-kids #:nsib #:md-value #:^md-value #:.md-value #:kids #:^kids #:.kids
--- /project/cells/cvsroot/cells/link.lisp	2006/06/07 22:12:55	1.11
+++ /project/cells/cvsroot/cells/link.lisp	2006/06/20 14:16:44	1.12
@@ -88,9 +88,7 @@
 ; ---------------------------------------------
 
 (defun cd-usage-clear-all (c)
-  (loop with a = (cd-usage c)
-        for bitn below (array-dimension a 0)
-        do (setf (sbit a bitn) 0)))
+  (setf (cd-usage c) (blank-usage-mask)))
 
 
 ;--- unlink from used ----------------------



From ktilton at common-lisp.net  Tue Jun 20 14:16:45 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue, 20 Jun 2006 10:16:45 -0400 (EDT)
Subject: [cells-cvs] CVS cells/cells-test
Message-ID: <20060620141645.49A041B000@common-lisp.net>

Update of /project/cells/cvsroot/cells/cells-test
In directory clnet:/tmp/cvs-serv24993/cells-test

Modified Files:
	hello-world.lisp test-kid-slotting.lisp test.lisp 
Log Message:


--- /project/cells/cvsroot/cells/cells-test/hello-world.lisp	2006/03/16 05:22:08	1.3
+++ /project/cells/cvsroot/cells/cells-test/hello-world.lisp	2006/06/20 14:16:45	1.4
@@ -24,15 +24,13 @@
 
 (in-package :cells)
 
-(defmodel computer ()
-  ((happen :cell :ephemeral :initform (c-in nil) :accessor happen)
-   (location :cell t
-             :initform (c? (case (^happen)
-                              (:leave :away)
-                              (:arrive :at-home)
-                              (t .cache))) ;; ie, unchanged
-             :accessor location)
-   (response :cell :ephemeral :initform nil :initarg :response :accessor response)))
+(defmd computer ()
+  (happen (c-in nil) :ephemeral)
+  (location (c? (case (^happen)
+                  (:leave :away)
+                  (:arrive :at-home)
+                  (t .cache)))) ;; ie, unchanged
+  (response nil :ephemeral))
 
 (defobserver response(self new-response old-response)
   (when new-response
--- /project/cells/cvsroot/cells/cells-test/test-kid-slotting.lisp	2006/03/16 05:22:08	1.2
+++ /project/cells/cvsroot/cells/cells-test/test-kid-slotting.lisp	2006/06/20 14:16:45	1.3
@@ -24,33 +24,28 @@
 
 (in-package :cells)
 
-(defmodel image (family)
-  ((left :initform nil :initarg :left :accessor left)
-   (top :initform nil :initarg :top :accessor top)
-   (width :initform nil :initarg :width :accessor width)
-   (height :initform nil :initarg :height :accessor height)
-   ))
+(defmd image (family) left top width height)
 
 (defun right (x) (+ (left x) (width x)))
 (defun bottom (x) (+ (top x) (height x)))
 
-(defmodel stack (image)
-  ((justify :initform :left :initarg :justify :accessor justify)
-   (.kid-slots :initform (lambda (self)
-                           (declare (ignore self))
-                           (list
-                            (mk-kid-slot (left :if-missing t)
-                              (c? (+ (left .parent)
-                                    (ecase (justify .parent)
-                                      (:left 0)
-                                      (:center (floor (- (width .parent) (^width)) 2))
-                                      (:right (- (width .parent) (^width)))))))
-                            (mk-kid-slot (top)
-                              (c? (bif (psib (psib))
-                                    (bottom psib)
-                                    (top .parent))))))
-     :accessor kid-slots
-     :initarg :kid-slots)))
+(defmd stack (image)
+  justify
+  (.kid-slots :initform (lambda (self)
+                          (declare (ignore self))
+                          (list
+                           (mk-kid-slot (left :if-missing t)
+                             (c? (+ (left .parent)
+                                   (ecase (justify .parent)
+                                     (:left 0)
+                                     (:center (floor (- (width .parent) (^width)) 2))
+                                     (:right (- (width .parent) (^width)))))))
+                           (mk-kid-slot (top)
+                             (c? (bif (psib (psib))
+                                   (bottom psib)
+                                   (top .parent))))))
+    :accessor kid-slots
+    :initarg :kid-slots))
 ;;
 ;; kid-slotting exists largely so graphical containers can be defined which arrange their
 ;; component parts without those parts' cooperation. so a stack class can be defined as shown
--- /project/cells/cvsroot/cells/cells-test/test.lisp	2006/06/13 05:05:14	1.6
+++ /project/cells/cvsroot/cells/cells-test/test.lisp	2006/06/20 14:16:45	1.7
@@ -65,7 +65,6 @@
 
 (defvar *cell-tests* nil)
 
-
 #+go
 (test-cells)
 
@@ -99,12 +98,10 @@
 
 ;; test huge number of useds by one rule
 
-(defmodel m-index (family)
-  ()
-  (:default-initargs
-      :md-value (c? (bwhen (ks (^kids))
-                      ;(trc "chya" (mapcar 'md-value ks))
-                      (apply '+ (mapcar 'md-value ks))))))
+(defmd m-index (family)
+  :md-value (c? (bwhen (ks (^kids))
+                  ;(trc "chya" (mapcar 'md-value ks))
+                  (apply '+ (mapcar 'md-value ks)))))
 
 (def-cell-test many-useds
     (let ((i (make-instance 'm-index)))
@@ -119,18 +116,18 @@
 #+test
 (many-useds)
 
-(defmodel m-null ()
-  ((aa :initform nil :cell nil :initarg :aa :accessor aa)))
+(defmd m-null () 
+  (aa :cell nil :initform nil :initarg :aa :accessor aa))
+
 
 (def-cell-test m-null
     (let ((m (make-instance 'm-null :aa 42)))
       (ct-assert (= 42 (aa m)))
-      (ct-assert (= 21 (decf (aa m) 21)))
+      (ct-assert (= 21 (let ((slot 'aa))
+                         (funcall (fdefinition `(setf ,slot)) (- (aa m) 21) m))))
       :okay-m-null))
 
-(defmodel m-solo ()
-  ((m-solo-a :initform nil :initarg :m-solo-a :accessor m-solo-a)
-   (m-solo-b :initform nil :initarg :m-solo-b :accessor m-solo-b)))
+(defmd m-solo () m-solo-a m-solo-b)
 
 (def-cell-test m-solo
     (let ((m (make-instance 'm-solo
@@ -143,9 +140,7 @@
       (ct-assert (= 82 (m-solo-b m)))
       :okay-m-null))
 
-(defmodel m-var ()
-  ((m-var-a :initform nil :initarg :m-var-a :accessor m-var-a)
-   (m-var-b :initform nil :initarg :m-var-b :accessor m-var-b)))
+(defmd m-var () m-var-a m-var-b)
 
 (defobserver m-var-b ()
   (print `(output m-var-b ,self ,new-value ,old-value)))
@@ -157,9 +152,9 @@
     (ct-assert (= 21 (m-var-a m)))
     :okay-m-var))
 
-(defmodel m-var-output ()
-  ((cbb :initform nil :initarg :cbb :accessor cbb)
-   (aa :cell nil :initform nil :initarg :aa :accessor aa)))
+(defmd m-var-output ()
+  cbb
+  (aa :cell nil :initform nil :initarg :aa :accessor aa))
 
 (defobserver cbb ()
   (trc "output cbb" self)
@@ -175,9 +170,7 @@
     (ct-assert (eql -15 (aa m)))
     (list :okay-m-var (aa m))))
 
-(defmodel m-var-linearize-setf ()
-  ((ccc :initform nil :initarg :ccc :accessor ccc)
-   (ddd :initform nil :initarg :ddd :accessor ddd)))
+(defmd m-var-linearize-setf () ccc ddd)
 
 (defobserver ccc ()
   (with-integrity (:change)
@@ -198,9 +191,9 @@
 
 ;;; -------------------------------------------------------
 
-(defmodel m-ruled ()
-  ((eee :initform nil :initarg :eee :accessor eee)
-   (fff :initform (c? (floor (^ccc) 2)) :initarg :fff :accessor fff)))
+(defmd m-ruled ()
+  eee
+  (fff (c? (floor (^ccc) 2))))
 
 (defobserver eee ()
   (print `(output> eee ,new-value old ,old-value)))
@@ -222,15 +215,15 @@
     (ct-assert (= 18 (fff m)) m)
     :okay-m-ruled))
 
-(defmodel m-worst-case ()
-  ((wc-x :accessor wc-x :initform (c-input () 2))
-   (wc-a :accessor wc-a :initform (c? (prog2
-                                        (trc "Start A")
-                                          (when (oddp (wc-x self))
-                                            (wc-c self))
-                                        (trc "Stop A"))))
-   (wc-c :accessor wc-c :initform (c? (evenp (wc-x self))))
-   (wc-h :accessor wc-h :initform (c? (or (wc-c self)(wc-a self))))))
+(defmd m-worst-case ()
+  (wc-x (c-input () 2))
+  (wc-a (c? (prog2
+              (trc "Start A")
+                (when (oddp (wc-x self))
+                  (wc-c self))
+              (trc "Stop A"))))
+  (wc-c (c? (evenp (wc-x self))))
+  (wc-h (c? (or (wc-c self)(wc-a self)))))
 
 (defun dependency-dump (self)
   (let ((slot-cells (loop for esd in (class-slots (class-of self))
@@ -252,10 +245,9 @@
     (dependency-dump m)
     (ct-assert (eql 3 (incf (wc-x m))))))
 
-(defmodel c?n-class ()
-  ((aaa :initarg :aaa :accessor aaa)
-   (bbb :initarg :bbb :accessor bbb)
-   (sum :initarg :sum :accessor sum :initform (c? (+ (^aaa) (^bbb))))))
+(defmd c?n-class ()
+  aaa bbb
+  (sum (c? (+ (^aaa) (^bbb)))))
 
 (def-cell-test test-c?n ()
   (let ((self (make-instance 'c?n-class



From ktilton at common-lisp.net  Tue Jun 20 14:16:45 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue, 20 Jun 2006 10:16:45 -0400 (EDT)
Subject: [cells-cvs] CVS cells/gui-geometry
Message-ID: <20060620141645.866D51B001@common-lisp.net>

Update of /project/cells/cvsroot/cells/gui-geometry
In directory clnet:/tmp/cvs-serv24993/gui-geometry

Modified Files:
	defpackage.lisp geo-data-structures.lisp 
Log Message:


--- /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp	2006/06/09 17:21:35	1.3
+++ /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp	2006/06/20 14:16:45	1.4
@@ -18,12 +18,12 @@
   (:nicknames #:geo)
   (:use #:common-lisp #:utils-kt #:cells)
   (:export #:geometer #:geo-zero-tl #:geo-inline #:a-stack #:a-row
-    #:px #:py #:ll #:lt #:lr #:lb
+    #:px #:py #:ll #:lt #:lr #:lb #:pl #:pt #:pr #:pb
     #:^px #:^py #:^ll #:^lt #:^lr #:^lb
     #:u96ths #:udots #:uinches #:uin #:upoints #:upts #:u8ths #:u16ths #:u32nds
     #:mkr #:v2-move #:l-height #:mkv2 #:^offset-within #:inset-lr #:v2-v #:v2-h
     #:r-bounds 
-    #:lb 
+    #:lb
     #:cs-target-res 
     #:nr-make 
     #:r-contains 
--- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp	2006/06/04 13:19:59	1.1
+++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp	2006/06/20 14:16:45	1.2
@@ -216,7 +216,11 @@
        (setf min-h 0 min-v 0 max-h 0 max-v 0))
      (nr-make r min-h min-v max-h max-v))))
 
-
+(defun nr-union (r sr) ;; unlike other code, this is assuming opengl's up==plus, and proper rectangles
+  (nr-make r (min (r-left r) (r-left sr))
+    (max (r-top r) (r-top sr))
+    (max (r-right r) (r-right sr))
+    (min (r-bottom r) (r-bottom sr))))
 
 (defun nr-move-to (r h v)
    (setf (r-left r) h



From ktilton at common-lisp.net  Tue Jun 20 14:16:45 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue, 20 Jun 2006 10:16:45 -0400 (EDT)
Subject: [cells-cvs] CVS cells/tutorial
Message-ID: <20060620141645.BA8CD1B000@common-lisp.net>

Update of /project/cells/cvsroot/cells/tutorial
In directory clnet:/tmp/cvs-serv24993/tutorial

Modified Files:
	tutorial.lpr 
Log Message:


--- /project/cells/cvsroot/cells/tutorial/tutorial.lpr	2006/06/13 16:19:35	1.4
+++ /project/cells/cvsroot/cells/tutorial/tutorial.lpr	2006/06/20 14:16:45	1.5
@@ -18,7 +18,8 @@
                  (make-instance 'module :name "05-class-cell.lisp")
                  (make-instance 'module :name
                                 "..\\gotchas\\lost-ephemeral-init.lisp")
-                 (make-instance 'module :name "chat-cells.lisp"))
+                 (make-instance 'module :name "chat-cells.lisp")
+                 (make-instance 'module :name "df-interference.lisp"))
   :projects (list (make-instance 'project-module :name "..\\cells"))
   :libraries nil
   :distributed-files nil



From ktilton at common-lisp.net  Fri Jun 23 01:04:56 2006
From: ktilton at common-lisp.net (ktilton)
Date: Thu, 22 Jun 2006 21:04:56 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060623010456.7D79D1005@common-lisp.net>

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

Modified Files:
	cell-types.lisp cells-manifesto.txt cells.lisp cells.lpr 
	defmodel.lisp initialize.lisp integrity.lisp link.lisp 
	md-slot-value.lisp md-utilities.lisp model-object.lisp 
	optimization.lisp propagate.lisp synapse.lisp test.lisp 
Log Message:
New abbreviated defmodel: defmd

Starting to change internals names as the mood hits me.

--- /project/cells/cvsroot/cells/cell-types.lisp	2006/06/20 14:16:44	1.13
+++ /project/cells/cvsroot/cells/cell-types.lisp	2006/06/23 01:04:55	1.14
@@ -26,7 +26,7 @@
   inputp ;; t for old c-variable class
   synaptic
   changed
-  (users-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify users FIFO
+  (caller-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify callers FIFO
   
   (state :nascent :type symbol) ;; :nascent, :awake, :optimized-away
   (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :valid}
@@ -34,16 +34,16 @@
   debug
   md-info)
 
-(defun c-users (c)
+(defun c-callers (c)
   "Make it easier to change implementation"
-  (fifo-data (c-users-store c)))
+  (fifo-data (c-caller-store c)))
 
-(defun user-ensure (used new-user)
-  (unless (find new-user (c-users used))
-    (fifo-add (c-users-store used) new-user)))
+(defun caller-ensure (used new-caller)
+  (unless (find new-caller (c-callers used))
+    (fifo-add (c-caller-store used) new-caller)))
 
-(defun user-drop (used user)
-  (fifo-delete (c-users-store used) user))
+(defun caller-drop (used caller)
+  (fifo-delete (c-caller-store used) caller))
 
 (defmethod trcp ((c cell))
   nil #+(or) (and (typep (c-model c) 'index)
@@ -61,7 +61,7 @@
     ;
     ; as of Cells3 we defer resetting ephemerals because everything
     ; else gets deferred and we cannot /really/ reset it until
-    ; within finish-business we are sure all users have been recalculated
+    ; within finish-business we are sure all callers have been recalculated
     ; and all outputs completed.
     ;
     ; ;; good q: what does (setf <ephem> 'x) return? historically nil, but...?
@@ -71,8 +71,8 @@
       (md-slot-value-store (c-model c) (c-slot-name c) nil)
       (setf (c-value c) nil)
       #+notsureaboutthis
-      (loop for user in (c-users c)
-            do (calculate-and-link user)))))
+      (loop for caller in (c-callers c)
+            do (calculate-and-link caller)))))
 
 ; -----------------------------------------------------
 
--- /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/20 14:16:44	1.6
+++ /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/23 01:04:56	1.7
@@ -61,7 +61,8 @@
 way around it, and thus his prediction that a software silver bullet was
 in principle impossible.
 
-Which brings us to Cells.
+Which brings us to Cells. See also [axiom] Phillip Eby's developiong axiomatic 
+definition he is developing in support of Ryan Forseth's SoC project.
 
 DEFMODEL and Slot types
 -----------------------
@@ -392,3 +393,118 @@
 was done on having slots of DEFSTRUCTs mediated by Cells, and ports to C++, Java, and
 Python have been explored.
 
+_______
+[axiom] Phillip Eby's axiomatic specification of Cells:
+
+Data Pulse Axioms
+=================
+
+Overview: updates must be synchronous (all changed cells are updated at
+once), consistent (no cell rule sees out of date values), and minimal (only
+necessary rules run).
+
+1. Global Update Counter:
+   There is a global update counter. (Guarantees that there is a
+globally-consistent notion of the "time" at which updates occur.)
+
+2. Per-Cell "As Of" Value:
+   Every cell has a "current-as-of" update count, that is initialized with
+a value that is less than the global update count will ever be.
+
+3. Out-of-dateness:
+   A cell is out of date if its update count is lower than the update
+count of any of the cells it depends on.
+
+4. Out-of-date Before:
+   When a rule-driven cell's value is queried, its rule is only run if the
+cell is out of date; otherwise a cached previous value is
+returned.  (Guarantees that a rule is not run unless its dependencies have
+changed since the last time the rule was run.)
+
+5. Up-to-date After:
+   Once a cell's rule is run (or its value is changed, if it is an input
+cell), its update count must be equal to the global update
+count.  (Guarantees that a rule cannot run more than once per update.)
+
+6. Inputs Move The System Forward
+   When an input cell changes, it increments the global update count and
+stores the new value in its own update count.
+
+
+Dependency Discovery Axioms
+===========================
+
+Overview: cells automatically notice when other cells depend on them, then
+notify them at most once if there is a change.
+
+
+1. Thread-local "current rule cell":
+   There is a thread-local variable that always contains the cell whose
+rule is currently being evaluated in the corresponding thread.  This
+variable can be empty (e.g. None).
+
+2. "Currentness" Maintenance:
+   While a cell rule's is being run, the variable described in #1 must be
+set to point to the cell whose rule is being run.  When the rule is
+finished, the variable must be restored to whatever value it had before the
+rule began.  (Guarantees that cells will be able to tell who is asking for
+their values.)
+
+3. Dependency Creation:
+   When a cell is read, it adds the "currently-being evaluated" cell as a
+listener that it will notify of changes.
+
+4. Dependency Creation Order:
+   New listeners are added only *after* the cell being read has brought
+itself up-to-date, and notified any *previous* listeners of the
+change.  (Ensures that the listening cell does not receive redundant
+notification if the listened-to cell has to be brought up-to-date first.)
+
+5. Dependency Minimalism:
+   A listener should only be added if it does not already present in the
+cell's listener collection.  (This isn't strictly mandatory, the system
+behavior will be correct but inefficient if this requirement isn't met.)
+
+6. Dependency Removal:
+   Just before a cell's rule is run, it must cease to be a listener for
+any other cells.  (Guarantees that a dependency from a previous update
+cannot trigger an unnecessary repeated calculation.)
+
+7. Dependency Notification
+   Whenever a cell's value changes (due to a rule change or input change),
+it must notify all of its listeners that it has changed, in such a way that
+*none* of the listeners are asked to recalculate their value until *all* of
+the listeners have first been notified of the change.  (This guarantees
+that inconsistent views cannot occur.)
+
+7a. Deferred Recalculation
+    The recalculation of listeners (not the notification of the listeners'
+out-of-dateness) must be deferred if a cell's value is currently being
+calculated.  As soon as there are no cells being calculated, the deferred
+recalculations must occur.  (This guarantees that in the absence of
+circular dependencies, no cell can ask for a value that's in the process of
+being calculated.)
+
+8. One-Time Notification Only
+   A cell's listeners are removed from its listener collection as soon as
+they have been notified.  In particular, the cell's collection of listeners
+must be cleared *before* *any* of the listeners are asked to recalculate
+themselves.  (This guarantees that listeners reinstated as a side effect of
+recalculation will not get a duplicate notification in the current update,
+or miss a notification in a future update.)
+
+9. Conversion to Constant
+   If a cell's rule is run and no dependencies were created, the cell must
+become a "constant" cell, and do no further listener additions or
+notification, once any necessary notifications to existing listeners are
+completed.  (That is, if the rule's run changed the cell's value, it must
+notify its existing listeners, but then the listener collection must be
+cleared -- *again*, in addition to the clearing described in #8.)
+
+10. No Changes During Notification:
+   It is an error to change an input cell's value while change
+notifications are taking place.
+
+11. Weak Notification
+   Automatically created inter-cell links must not inhibit garbage
+collection of either cell.  (Technically optional, but very easy to do.)
--- /project/cells/cvsroot/cells/cells.lisp	2006/06/10 22:16:35	1.12
+++ /project/cells/cvsroot/cells/cells.lisp	2006/06/23 01:04:56	1.13
@@ -64,7 +64,7 @@
             `(c-break ,fmt$ , at fmt-args)
           `(c-break "failed assertion: ~a" ',assertion)))))
 
-(defvar *c-calculators* nil)
+(defvar *call-stack* nil)
 
 (defmacro def-c-trace (model-type &optional slot cell-type)
   `(defmethod trcp ((self ,(case cell-type
@@ -76,7 +76,7 @@
           `t))))
 
 (defmacro without-c-dependency (&body body)
-  `(let (*c-calculators*) , at body))
+  `(let (*call-stack*) , at body))
 
 (define-symbol-macro .cause
     (car *causation*))
--- /project/cells/cvsroot/cells/cells.lpr	2006/05/30 02:47:45	1.14
+++ /project/cells/cvsroot/cells/cells.lpr	2006/06/23 01:04:56	1.15
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 
--- /project/cells/cvsroot/cells/defmodel.lisp	2006/06/20 14:16:44	1.5
+++ /project/cells/cvsroot/cells/defmodel.lisp	2006/06/23 01:04:56	1.6
@@ -124,6 +124,7 @@
 (defun defmd-canonicalize-slot (slotname
                                  &key
                                  (cell nil cell-p)
+                                (type nil type-p)
                                  (initform nil initform-p)
                                  (initarg (intern (symbol-name slotname) :keyword))
                                  (documentation nil documentation-p)
@@ -135,6 +136,7 @@
   (list* slotname :initarg initarg
     (append
      (when cell-p (list :cell cell))
+     (when type-p (list :type type))
      (when initform-p (list :initform initform))
      (when unchanged-if-p (list :unchanged-if unchanged-if))
      (when reader-p (list :reader reader))
@@ -158,7 +160,7 @@
                          ((keywordp (car spec))
                           (assert (find (car spec) '(:documentation :metaclass)))
                           (push spec class-options))
-                         ((find (cadr spec) '(:initarg :cell :initform :allocation :reader :writer :accessor :documentation))
+                         ((find (cadr spec) '(:initarg :type :cell :initform :allocation :reader :writer :accessor :documentation))
                           (push (apply 'defmd-canonicalize-slot spec) slots))
                          (t ;; shortform (slotname initform &rest slotdef-key-values)
                           (push (apply 'defmd-canonicalize-slot
--- /project/cells/cvsroot/cells/initialize.lisp	2006/06/13 16:19:35	1.7
+++ /project/cells/cvsroot/cells/initialize.lisp	2006/06/23 01:04:56	1.8
@@ -36,13 +36,13 @@
   (ephemeral-reset c))
 
 (defmethod awaken-cell ((c c-ruled))
-  (let (*c-calculators*)
+  (let (*call-stack*)
     (calculate-and-set c)))
 
 #+cormanlisp ; satisfy CormanCL bug
 (defmethod awaken-cell ((c c-dependent))
-  (let (*c-calculators*)
-    (trc nil "awaken-cell c-dependent clearing *c-calculators*" c)
+  (let (*call-stack*)
+    (trc nil "awaken-cell c-dependent clearing *call-stack*" c)
     (calculate-and-set c)))
 
 (defmethod awaken-cell ((c c-drifter))
--- /project/cells/cvsroot/cells/integrity.lisp	2006/05/20 06:32:19	1.9
+++ /project/cells/cvsroot/cells/integrity.lisp	2006/06/23 01:04:56	1.10
@@ -64,7 +64,7 @@
   (let ((*within-integrity* nil)
           *unfinished-business*
           *defer-changes*
-        *c-calculators*
+        *call-stack*
         (*data-pulse-id* 0))
     (funcall action)))
 
@@ -138,7 +138,7 @@
     ; of cells3, I coded an ephemeral cell and initialized it to non-nil, hitting a runtime
     ; error (now gone) saying I had no idea what a non-nil ephemeral would mean. That had been
     ; my conclusion when the idea occurred to me the first time, so I stuck in an assertion
-    ; to warn off users. 
+    ; to warn off callers. 
     ;
     ; But the new
     ; datachange progression defined by Cells3 had already forced me to manage ephemeral resets
--- /project/cells/cvsroot/cells/link.lisp	2006/06/20 14:16:44	1.12
+++ /project/cells/cvsroot/cells/link.lisp	2006/06/23 01:04:56	1.13
@@ -22,13 +22,13 @@
 (eval-when (compile load)
  (proclaim '(optimize (speed 3) (safety 0) (space 0) (debug 0))))
 
-(defun c-link-ex (used &aux (user (car *c-calculators*)))
+(defun record-caller (used &aux (caller (car *call-stack*)))
   (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell
-    (return-from c-link-ex nil))
-  (trc nil "c-link-ex entry: used=" used :user user)
+    (return-from record-caller nil))
+  (trc nil "record-caller entry: used=" used :caller caller)
   (multiple-value-bind (used-pos useds-len)
       (loop with u-pos
-          for known in (cd-useds user)
+          for known in (cd-useds caller)
           counting known into length
           when (eq used known)
           do
@@ -37,20 +37,20 @@
           finally (return (values (when u-pos (- length u-pos)) length)))
 
     (when (null used-pos)
-      (trc nil "c-link > new user,used " user used)
+      (trc nil "c-link > new caller,used " caller used)
       (count-it :new-used)
       (setf used-pos useds-len)
-      (push used (cd-useds user))
-      (user-ensure used user) ;; 060604 experiment was in unlink
+      (push used (cd-useds caller))
+      (caller-ensure used caller) ;; 060604 experiment was in unlink
       )
 
     (handler-case
-        (setf (sbit (cd-usage user) used-pos) 1)
+        (setf (sbit (cd-usage caller) used-pos) 1)
       (type-error (error)
         (declare (ignorable error))
-        (setf (cd-usage user)
-          (adjust-array (cd-usage user) (+ used-pos 16) :initial-element 0))
-        (setf (sbit (cd-usage user) used-pos) 1))))
+        (setf (cd-usage caller)
+          (adjust-array (cd-usage caller) (+ used-pos 16) :initial-element 0))
+        (setf (sbit (cd-usage caller) used-pos) 1))))
   used)
 
 
@@ -64,10 +64,10 @@
                           (if (zerop (sbit usage rpos))
                               (progn
                                 (count-it :unlink-unused)
-                                (c-unlink-user (car useds) c)
+                                (c-unlink-caller (car useds) c)
                                 (rplaca useds nil))
                             (progn
-                              ;; moved into c-link-ex 060604 (user-ensure (car useds) c)
+                              ;; moved into record-caller 060604 (caller-ensure (car useds) c)
                               )
                             )))
                    (if (cdr useds)
@@ -78,12 +78,12 @@
         (nail-unused (cd-useds c))
         (setf (cd-useds c) (delete-if #'null (cd-useds c)))))))
 
-(defun c-user-path-exists-p (from-used to-user)
-  (count-it :user-path-exists-p)
-  (or (find to-user (c-users from-used))
-    (find-if (lambda (from-used-user)
-               (c-user-path-exists-p from-used-user to-user))
-      (c-users from-used))))
+(defun c-caller-path-exists-p (from-used to-caller)
+  (count-it :caller-path-exists-p)
+  (or (find to-caller (c-callers from-used))
+    (find-if (lambda (from-used-caller)
+               (c-caller-path-exists-p from-used-caller to-caller))
+      (c-callers from-used))))
 
 ; ---------------------------------------------
 
@@ -93,11 +93,11 @@
 
 ;--- unlink from used ----------------------
                      
-(defmethod c-unlink-from-used ((user c-dependent))
-  (dolist (used (cd-useds user))
-    #+dfdbg (trc user "unlinking from used" user used)
-    (c-unlink-user used user))
-  ;; shouldn't be necessary (setf (cd-useds user) nil)
+(defmethod c-unlink-from-used ((caller c-dependent))
+  (dolist (used (cd-useds caller))
+    #+dfdbg (trc caller "unlinking from used" caller used)
+    (c-unlink-caller used caller))
+  ;; shouldn't be necessary (setf (cd-useds caller) nil)
   )
 
 (defmethod c-unlink-from-used (other)
@@ -105,20 +105,20 @@
 
 ;----------------------------------------------------------
 
-(defun c-unlink-user (used user)
-  (trc nil "user unlinking from used" user used)
-  (user-drop used user)
-  (c-unlink-used user used))
+(defun c-unlink-caller (used caller)
+  (trc nil "caller unlinking from used" caller used)
+  (caller-drop used caller)
+  (c-unlink-used caller used))
 
-(defun c-unlink-used (user used)
-  (setf (cd-useds user) (delete used (cd-useds user))))
+(defun c-unlink-used (caller used)
+  (setf (cd-useds caller) (delete used (cd-useds caller))))
 
 ;----------------- link debugging ---------------------
 
-(defun dump-users (c &optional (depth 0))
+(defun dump-callers (c &optional (depth 0))
      (format t "~&~v,4t~s" depth c)
-     (dolist (user (c-users c))
-          (dump-users user (+ 1 depth))))
+     (dolist (caller (c-callers c))
+          (dump-callers caller (+ 1 depth))))
 
 (defun dump-useds (c &optional (depth 0))
      ;(c.trc "dump-useds> entry " c (+ 1 depth))
@@ -130,3 +130,9 @@
           (dolist (used (cd-useds c))
                (dump-useds used (+ 1 depth)))))
 
+
+(defun test-wk ()
+  (let ((h (make-hash-table :test 'eq :weak-keys t)))
+    (loop for n below 10
+          do (setf (gethash (make-cell :value n) h) n))
+    (maphash (lambda (k v) (print (list k v))) h)))
\ No newline at end of file
--- /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/15 15:55:01	1.21
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/23 01:04:56	1.22
@@ -43,8 +43,8 @@
       (prog1
           (with-integrity ()
             (ensure-value-is-current c))
-        (when (car *c-calculators*)
-          (c-link-ex c)))
+        (when (car *call-stack*)
+          (record-caller c)))
     (values (bd-slot-value self slot-name) nil)))
   
 (defun ensure-value-is-current (c)
@@ -59,7 +59,7 @@
    ((or (not (c-validp c))
       (some (lambda (used)
               (ensure-value-is-current used)
-              (trc nil "comparing pulses (user, used): " (c-pulse c)(c-pulse used))
+              (trc nil "comparing pulses (caller, used): " (c-pulse c)(c-pulse used))
               (when (and (c-changed used) (> (c-pulse used)(c-pulse c)))
                  (trc nil "used changed" c used)
                 t))
@@ -80,9 +80,9 @@
              (princ #\.)
              (return-from calculate-and-set))
            
-           (when (find c *c-calculators*) ;; circularity
+           (when (find c *call-stack*) ;; circularity
              (c-break ;; break is problem when testing cells on some CLs
-              "cell ~a midst askers: ~a" c *c-calculators*))
+              "cell ~a midst askers: ~a" c *call-stack*))
   
            (multiple-value-bind (raw-value propagation-code)
                (calculate-and-link c)
@@ -97,7 +97,7 @@
       (body))))
 
 (defun calculate-and-link (c)
-  (let ((*c-calculators* (cons c *c-calculators*))
+  (let ((*call-stack* (cons c *call-stack*))
         (*defer-changes* t))
     (cd-usage-clear-all c)
     (multiple-value-prog1
--- /project/cells/cvsroot/cells/md-utilities.lisp	2006/06/13 05:05:13	1.5
+++ /project/cells/cvsroot/cells/md-utilities.lisp	2006/06/23 01:04:56	1.6
@@ -47,7 +47,7 @@
   (trc nil "md-quiesce doing" self (type-of self))
   (md-map-cells self nil (lambda (c)
                            (trc nil "quiescing" c)
-                           (c-assert (not (find c *c-calculators*)))
+                           (c-assert (not (find c *call-stack*)))
                            (c-quiesce c))))
 
 (defun c-quiesce (c)
@@ -56,8 +56,8 @@
      (trc nil "c-quiesce unlinking" c)
      (c-unlink-from-used c)
      (when (typep c 'cell)
-       (dolist (user (c-users c))
-         (c-unlink-user c user)))
+       (dolist (caller (c-callers c))
+         (c-unlink-caller c caller)))
       (trc nil "cell quiesce nulled cell awake" c))))
 
 (defmethod not-to-be (other)
--- /project/cells/cvsroot/cells/model-object.lisp	2006/06/13 16:19:35	1.7
+++ /project/cells/cvsroot/cells/model-object.lisp	2006/06/23 01:04:56	1.8
@@ -194,7 +194,7 @@
   (bif (entry (assoc slot-name (cells self)))
     (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter
       (declare (ignorable old))
-      (c-assert (null (c-users old)))
+      (c-assert (null (c-callers old)))
       (c-assert (null (cd-useds old)))
       (trc nil "replacing in model .cells" old new-cell self)
       (rplacd entry new-cell))
--- /project/cells/cvsroot/cells/optimization.lisp	2006/06/10 22:16:35	1.7
+++ /project/cells/cvsroot/cells/optimization.lisp	2006/06/23 01:04:56	1.8
@@ -45,9 +45,9 @@
              (setf (cells (c-model c)) (delete entry (cells (c-model c))))
              (push entry (cells-flushed (c-model c))))
            
-           (dolist (user (c-users c))
-             (setf (cd-useds user) (delete c (cd-useds user)))
-             (c-optimize-away?! user) ;; rare but it happens when rule says (or .cache ...)
+           (dolist (caller (c-callers c))
+             (setf (cd-useds caller) (delete c (cd-useds caller)))
+             (c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...)
              )
            t)
        
--- /project/cells/cvsroot/cells/propagate.lisp	2006/06/13 16:19:35	1.17
+++ /project/cells/cvsroot/cells/propagate.lisp	2006/06/23 01:04:56	1.18
@@ -61,17 +61,17 @@
 
   (count-it :c-propagate)
   
-  (let (*c-calculators* 
+  (let (*call-stack* 
         (*c-prop-depth*  (1+ *c-prop-depth*))
         (*defer-changes* t))
-    (trc nil "c-propagate clearing *c-calculators*" c)
+    (trc nil "c-propagate clearing *call-stack*" c)
 
     ;------ debug stuff ---------
     ;
     (when *stop*
       (princ #\.)(princ #\!)
       (return-from c-propagate))    
-    (trc nil "c-propagate> propping" c (c-value c) :user-ct (length (c-users c)) c)
+    (trc nil "c-propagate> propping" c (c-value c) :caller-ct (length (c-callers c)) c)
     
     (when *c-debug*
       (when (> *c-prop-depth* 250)
@@ -81,7 +81,7 @@
     
     ; --- manifest new value as needed ---
     ;
-    ; propagation to users jumps back in front of client slot-value-observe handling in cells3
+    ; propagation to callers jumps back in front of client slot-value-observe handling in cells3
     ; because model adopting (once done by the kids change handler) can now be done in
     ; shared-initialize (since one is now forced to supply the parent to make-instance).
     ;
@@ -89,7 +89,7 @@
     ; expected to have side-effects, so we want to propagate fully and be sure no rule
     ; wants a rollback before starting with the side effects.
     ; 
-    (c-propagate-to-users c)
+    (c-propagate-to-callers c)
 
     (slot-value-observe (c-slot-name c) (c-model c)
       (c-value c) prior-value prior-value-supplied)
@@ -98,7 +98,7 @@
     ; let the fn decide if C really is ephemeral. Note that it might be possible to leave
     ; this out and use the datapulse to identify obsolete ephemerals and clear them
     ; when read. That would avoid ever making again bug I had in which I had the reset inside slot-value-observe,
-    ; thinking that that always followed propagation to users. It would also make
+    ; thinking that that always followed propagation to callers. It would also make
     ; debugging easier in that I could find the last ephemeral value in the inspector.
     ; would this be bad for persistent CLOS, in which a DB would think there was still a link
     ; between two records until the value actually got cleared?
@@ -147,29 +147,29 @@
 
 ; --- recalculate dependents ----------------------------------------------------
 
-(defun c-propagate-to-users (c)
+(defun c-propagate-to-callers (c)
   ;
-  ;  We must defer propagation to users because of an edge case in which:
+  ;  We must defer propagation to callers because of an edge case in which:
   ;    - X tells A to recalculate
   ;    - A asks B for its current value
   ;    - B must recalculate because it too uses X
-  ;    - if B propagates to its users after recalculating instead of deferring it
+  ;    - if B propagates to its callers after recalculating instead of deferring it
   ;       - B might tell H to reclaculate, where H decides this time to use A
   ;       - but A is in the midst of recalculating, and cannot complete until B returns.
   ;         but B is busy eagerly propagating. "This time" is important because it means
   ;         there is no way one can reliably be sure H will not ask for A
   ;
-  (when (c-users c)
-    (trc nil "c-propagate-to-users > queueing" c)
+  (when (c-callers c)
+    (trc nil "c-propagate-to-callers > queueing" c)
     (let ((causation (cons c *causation*))) ;; in case deferred
       (with-integrity (:tell-dependents c)
-        (assert (null *c-calculators*))
+        (assert (null *call-stack*))
         (let ((*causation* causation))
-          (trc nil "c-propagate-to-users > notifying users of" c (mapcar 'c-slot-name (c-users c)))
-          (dolist (user (c-users c))
-            (unless (member (cr-lazy user) '(t :always :once-asked))
-              (trc nil "propagating to user is (used,user):" c user)
-              (ensure-value-is-current user))))))))
+          (trc nil "c-propagate-to-callers > notifying callers of" c (mapcar 'c-slot-name (c-callers c)))
+          (dolist (caller (c-callers c))
+            (unless (member (cr-lazy caller) '(t :always :once-asked))
+              (trc nil "propagating to caller is (used,caller):" c caller)
+              (ensure-value-is-current caller))))))))
 
 
 
--- /project/cells/cvsroot/cells/synapse.lisp	2006/06/13 05:05:13	1.11
+++ /project/cells/cvsroot/cells/synapse.lisp	2006/06/23 01:04:56	1.12
@@ -23,19 +23,19 @@
 
 (defmacro with-synapse (synapse-id (&rest closure-vars) &body body)
   (declare (ignorable trcp))
-  (let ((syn-id (gensym))(syn-user (gensym)))
+  (let ((syn-id (gensym))(syn-caller (gensym)))
     `(let* ((,syn-id ,synapse-id)
-            (,syn-user (car *c-calculators*))
-            (synapse (or (find ,syn-id (cd-useds ,syn-user) :key 'c-slot-name)
+            (,syn-caller (car *call-stack*))
+            (synapse (or (find ,syn-id (cd-useds ,syn-caller) :key 'c-slot-name)
                        (let ((new-syn
                               (let (, at closure-vars)
                                 (make-c-dependent
-                                 :model (c-model ,syn-user)
+                                 :model (c-model ,syn-caller)
                                  :slot-name ,syn-id
                                  :code ',body
                                  :synaptic t
                                  :rule (c-lambda , at body)))))
-                         (c-link-ex new-syn)
+                         (record-caller new-syn)
                          new-syn))))
        (prog1
            (multiple-value-bind (v p)
@@ -43,7 +43,7 @@
                  (ensure-value-is-current synapse))
              (trc nil "with-synapse: synapse, v, prop" synapse v p)
              (values v p))
-         (c-link-ex synapse)))))
+         (record-caller synapse)))))
 
 
 ;__________________________________________________________________________________
--- /project/cells/cvsroot/cells/test.lisp	2005/09/26 15:35:58	1.7
+++ /project/cells/cvsroot/cells/test.lisp	2006/06/23 01:04:56	1.8
@@ -34,14 +34,14 @@
 
 - make sure they fire when they should, and do not when they should not
 
-- make sure they survive an evaluation by the user which does not branch to
+- make sure they survive an evaluation by the caller which does not branch to
 them (ie, does not access them)
 
 - make sure they optimize away
 
 - test with forms which access multiple other cells
 
-- look at direct alteration of a user
+- look at direct alteration of a caller
 
 - does SETF honor not propagating, as well as a c-ruled after re-calcing
 



From ktilton at common-lisp.net  Fri Jun 23 01:04:56 2006
From: ktilton at common-lisp.net (ktilton)
Date: Thu, 22 Jun 2006 21:04:56 -0400 (EDT)
Subject: [cells-cvs] CVS cells/cells-test
Message-ID: <20060623010456.CF0B53063@common-lisp.net>

Update of /project/cells/cvsroot/cells/cells-test
In directory clnet:/tmp/cvs-serv31550/cells-test

Modified Files:
	df-interference.lisp hello-world.lisp test-synapse.lisp 
	test.lisp 
Log Message:
New abbreviated defmodel: defmd

Starting to change internals names as the mood hits me.

--- /project/cells/cvsroot/cells/cells-test/df-interference.lisp	2006/05/30 02:47:45	1.4
+++ /project/cells/cvsroot/cells/cells-test/df-interference.lisp	2006/06/23 01:04:56	1.5
@@ -64,7 +64,7 @@
 ;;     - b depends on c
 ;;
 ;; if c changes, depending on the accident of the order in which a and b happened to
-;; be first evaluated, a might appear before b on c's list of dependents (users). then the
+;; be first evaluated, a might appear before b on c's list of dependents (callers). then the
 ;; following happens:
 ;;
 ;;     - c triggers a
@@ -113,7 +113,7 @@
       (trc "cell is" c)
       (when (typep (cdr c) 'cell)
         (print `(notifier ,c))
-        (dolist (u (c-users (cdr c)))
+        (dolist (u (c-callers (cdr c)))
           (print `(___ ,u)))))
     ))
 
--- /project/cells/cvsroot/cells/cells-test/hello-world.lisp	2006/06/20 14:16:45	1.4
+++ /project/cells/cvsroot/cells/cells-test/hello-world.lisp	2006/06/23 01:04:56	1.5
@@ -24,13 +24,14 @@
 
 (in-package :cells)
 
+
 (defmd computer ()
-  (happen (c-in nil) :ephemeral)
+  (happen (c-in nil) :cell :ephemeral)
   (location (c? (case (^happen)
                   (:leave :away)
                   (:arrive :at-home)
                   (t .cache)))) ;; ie, unchanged
-  (response nil :ephemeral))
+  (response nil :cell :ephemeral))
 
 (defobserver response(self new-response old-response)
   (when new-response
--- /project/cells/cvsroot/cells/cells-test/test-synapse.lisp	2006/03/16 05:22:08	1.1
+++ /project/cells/cvsroot/cells/cells-test/test-synapse.lisp	2006/06/23 01:04:56	1.2
@@ -22,7 +22,6 @@
 
 (in-package :cells)
 
-
 (defmodel m-syn ()
   ((m-syn-a :initform nil :initarg :m-syn-a :accessor m-syn-a)
    (m-syn-b :initform nil :initarg :m-syn-b :accessor m-syn-b)
--- /project/cells/cvsroot/cells/cells-test/test.lisp	2006/06/20 14:16:45	1.7
+++ /project/cells/cvsroot/cells/cells-test/test.lisp	2006/06/23 01:04:56	1.8
@@ -34,14 +34,14 @@
 
 - make sure they fire when they should, and do not when they should not
 
-- make sure they survive an evaluation by the user which does not branch to
+- make sure they survive an evaluation by the caller which does not branch to
 them (ie, does not access them)
 
 - make sure they optimize away
 
 - test with forms which access multiple other cells
 
-- look at direct alteration of a user
+- look at direct alteration of a caller
 
 - does SETF honor not propagating, as well as a c-ruled after re-calcing
 
@@ -233,7 +233,7 @@
                      collect (cons sn c))))
     (trc "dependencies of" self)
     (loop for (sn . c) in slot-cells
-          do (trc "slot" sn :users (mapcar 'c-slot-name (c-users c))))))
+          do (trc "slot" sn :callers (mapcar 'c-slot-name (c-callers c))))))
 
 (def-cell-test m-worst-case
   (let ((m (make-instance 'm-worst-case)))



From ktilton at common-lisp.net  Fri Jun 23 01:04:57 2006
From: ktilton at common-lisp.net (ktilton)
Date: Thu, 22 Jun 2006 21:04:57 -0400 (EDT)
Subject: [cells-cvs] CVS cells/gui-geometry
Message-ID: <20060623010457.34B263063@common-lisp.net>

Update of /project/cells/cvsroot/cells/gui-geometry
In directory clnet:/tmp/cvs-serv31550/gui-geometry

Modified Files:
	defpackage.lisp geometer.lisp 
Log Message:
New abbreviated defmodel: defmd

Starting to change internals names as the mood hits me.

--- /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp	2006/06/20 14:16:45	1.4
+++ /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp	2006/06/23 01:04:57	1.5
@@ -22,7 +22,7 @@
     #:^px #:^py #:^ll #:^lt #:^lr #:^lb
     #:u96ths #:udots #:uinches #:uin #:upoints #:upts #:u8ths #:u16ths #:u32nds
     #:mkr #:v2-move #:l-height #:mkv2 #:^offset-within #:inset-lr #:v2-v #:v2-h
-    #:r-bounds 
+    #:r-bounds #:l-box
     #:lb
     #:cs-target-res 
     #:nr-make 
--- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp	2006/06/13 05:05:17	1.3
+++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp	2006/06/23 01:04:57	1.4
@@ -57,8 +57,8 @@
      :lr (c? (geo-kid-wrap self 'pr))
       :lb (c? (geo-kid-wrap self 'pb))))
 
-(defun l-rect (geo)
-  (count-it :l-rect)
+(defun l-box (geo)
+  (count-it :l-box)
    (mkr (ll geo) (lt geo) (lr geo) (lb geo)))
 
 ;---------- gOffset -------------------



From ktilton at common-lisp.net  Fri Jun 23 01:05:00 2006
From: ktilton at common-lisp.net (ktilton)
Date: Thu, 22 Jun 2006 21:05:00 -0400 (EDT)
Subject: [cells-cvs] CVS cells/utils-kt
Message-ID: <20060623010500.C72787800F@common-lisp.net>

Update of /project/cells/cvsroot/cells/utils-kt
In directory clnet:/tmp/cvs-serv31550/utils-kt

Modified Files:
	utils-kt.lpr 
Log Message:
New abbreviated defmodel: defmd

Starting to change internals names as the mood hits me.

--- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr	2006/05/24 20:39:38	1.11
+++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr	2006/06/23 01:04:57	1.12
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 



From ktilton at common-lisp.net  Sun Jun 25 21:30:34 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sun, 25 Jun 2006 17:30:34 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060625213034.868DB50006@common-lisp.net>

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

Modified Files:
	cells.lisp cells.lpr md-slot-value.lisp optimization.lisp 
Log Message:
Lose *c-optimizep* (and the sep source file next)

--- /project/cells/cvsroot/cells/cells.lisp	2006/06/23 01:04:56	1.13
+++ /project/cells/cvsroot/cells/cells.lisp	2006/06/25 21:30:34	1.14
@@ -21,7 +21,6 @@
 
 (in-package :cells)
 
-(define-constant *c-optimizep* t)
 (defparameter *c-prop-depth* 0)
 (defparameter *causation* nil)
 
--- /project/cells/cvsroot/cells/cells.lpr	2006/06/23 01:04:56	1.15
+++ /project/cells/cvsroot/cells/cells.lpr	2006/06/25 21:30:34	1.16
@@ -13,7 +13,6 @@
                  (make-instance 'module :name "initialize.lisp")
                  (make-instance 'module :name "md-slot-value.lisp")
                  (make-instance 'module :name "slot-utilities.lisp")
-                 (make-instance 'module :name "optimization.lisp")
                  (make-instance 'module :name "link.lisp")
                  (make-instance 'module :name "propagate.lisp")
                  (make-instance 'module :name "synapse.lisp")
--- /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/23 01:04:56	1.22
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/25 21:30:34	1.23
@@ -205,5 +205,31 @@
         
         absorbed-value)))
 
+;---------- optimizing away cells whose dependents all turn out to be constant ----------------
+;
+
+(defun c-optimize-away?! (c)
+  (when (and (typep c 'c-dependent)
+          (not (c-optimized-away-p c)) ;; c-streams (FNYI) may come this way repeatedly even if optimized away
+          (c-validp c)
+          (not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around)
+          ;; chop (every (lambda (lbl-syn) (null (cd-useds (cdr lbl-syn)))) (cd-synapses c))
+          (not (c-inputp c))
+          (null (cd-useds c)))
+         
+    (trc nil "optimizing away" c (c-state c))
+    (count-it :c-optimized)
+    
+    (setf (c-state c) :optimized-away)
+       
+    (let ((entry (rassoc c (cells (c-model c))))) ; move from cells to cells-flushed
+      (c-assert entry)
+      (setf (cells (c-model c)) (delete entry (cells (c-model c))))
+      (push entry (cells-flushed (c-model c))))
+       
+    (dolist (caller (c-callers c))
+      (setf (cd-useds caller) (delete c (cd-useds caller)))
+      (c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...)
+      )))
 
     
--- /project/cells/cvsroot/cells/optimization.lisp	2006/06/23 01:04:56	1.8
+++ /project/cells/cvsroot/cells/optimization.lisp	2006/06/25 21:30:34	1.9
@@ -18,41 +18,3 @@
 
 (in-package :cells)
 
-;---------- optimizing away cells whose dependents all turn out to be constant ----------------
-;
-
-(defun c-optimize-away?! (c)
-  (declare (ignorable c))
-
-  (typecase c
-    (c-dependent
-     (if (and *c-optimizep*
-           (not (c-optimized-away-p c)) ;; c-streams (FNYI) may come this way repeatedly even if optimized away
-           (c-validp c)
-           (not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around)
-           ;; chop (every (lambda (lbl-syn) (null (cd-useds (cdr lbl-syn)))) (cd-synapses c))
-           (not (c-inputp c))
-           (null (cd-useds c)))
-         
-         (progn
-           (trc nil "optimizing away" c (c-state c))
-           (count-it :c-optimized)
-           
-           (setf (c-state c) :optimized-away)
-
-           (let ((entry (rassoc c (cells (c-model c))))) ; move from cells to cells-flushed
-             (c-assert entry)
-             (setf (cells (c-model c)) (delete entry (cells (c-model c))))
-             (push entry (cells-flushed (c-model c))))
-           
-           (dolist (caller (c-callers c))
-             (setf (cd-useds caller) (delete c (cd-useds caller)))
-             (c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...)
-             )
-           t)
-       
-       (progn
-         (trc nil "not optimizing away" *c-optimizep* (car (cd-useds c)) (c-validp c))
-         ;  (count-it :c-not-optimize)
-         ;  (count-it (intern-keyword "noopti-" #+nah (c-model c) "-" (symbol-name (c-slot-name c))))
-         )))))



From ktilton at common-lisp.net  Sun Jun 25 21:30:34 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sun, 25 Jun 2006 17:30:34 -0400 (EDT)
Subject: [cells-cvs] CVS cells/gui-geometry
Message-ID: <20060625213034.C30CD50006@common-lisp.net>

Update of /project/cells/cvsroot/cells/gui-geometry
In directory clnet:/tmp/cvs-serv26783/gui-geometry

Modified Files:
	geo-family.lisp gui-geometry.lpr 
Log Message:
Lose *c-optimizep* (and the sep source file next)

--- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp	2006/06/05 00:01:22	1.2
+++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp	2006/06/25 21:30:34	1.3
@@ -55,19 +55,6 @@
                                    (c? (px-maintain-pl
                                         (^prior-sib-pr self (spacing .parent)))))))))))
 
-(defmacro a-stack ((&rest stack-args) &body dd-kids)
-  `(mk-part ,(copy-symbol 'a-stack) (geo-inline)
-      , at stack-args
-     :fm-parent *parent*
-     :orientation :vertical
-     :kids (c? (the-kids , at dd-kids))))
-
-(defmacro a-row ((&rest stack-args) &body dd-kids)
-  `(mk-part ,(copy-symbol 'a-stack) (geo-inline)
-      , at stack-args
-     :fm-parent *parent*
-     :orientation :horizontal
-     :kids (c? (the-kids , at dd-kids))))
 
 #| archive
 
--- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr	2006/06/04 13:19:59	1.1
+++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr	2006/06/25 21:30:34	1.2
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 



From ktilton at common-lisp.net  Sun Jun 25 21:31:40 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sun, 25 Jun 2006 17:31:40 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060625213140.48E975601A@common-lisp.net>

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

Removed Files:
	optimization.lisp 
Log Message:





From ktilton at common-lisp.net  Thu Jun 29 09:54:06 2006
From: ktilton at common-lisp.net (ktilton)
Date: Thu, 29 Jun 2006 05:54:06 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060629095406.677EC61055@common-lisp.net>

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

Modified Files:
	cell-types.lisp cells-manifesto.txt cells.lpr family.lisp 
	md-slot-value.lisp model-object.lisp 
Log Message:


--- /project/cells/cvsroot/cells/cell-types.lisp	2006/06/23 01:04:55	1.14
+++ /project/cells/cvsroot/cells/cell-types.lisp	2006/06/29 09:54:06	1.15
@@ -141,7 +141,7 @@
 
 (defmethod print-object ((c cell) stream)
   (c-print-value c stream)
-  (format stream "=[~d]~a/~a]"
+  (format stream "=~d/~a/~a]"
     (c-pulse c)
     (symbol-name (or (c-slot-name c) :anoncell))
     (or (c-model c) :anonmd)))
@@ -151,7 +151,7 @@
 (defmethod c-print-value ((c c-ruled) stream)
   (format stream "~a" (cond ((c-validp c) "<vld>")
                             ((c-unboundp c) "<unb>")
-                            ((not (c-currentp c)) "<obs>")
+                            ((not (c-currentp c)) "dirty")
                             (t "<err>"))))
 
 (defmethod c-print-value (c stream)
--- /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/23 01:04:56	1.7
+++ /project/cells/cvsroot/cells/cells-manifesto.txt	2006/06/29 09:54:06	1.8
@@ -17,7 +17,7 @@
 cascade across the paper.
 
 VisiCalc let my father take the formula he had in mind and 
-put it in (declare it to) the electronic spreadsheet. Then VisiCalc 
+put it into (declare it to) the electronic spreadsheet. Then VisiCalc 
 could do the tedious work: recalculating, knowing what to recalculate, 
 and knowing in what order to recalculate.
 
@@ -75,11 +75,12 @@
 
    :cell {nil | t | :ephemeral}
 
-:cell is optional. The default is ":cell t", meaning the Cells engine will manage the slot. 
-Specifying NIL signifies that this slot is entirely 
+:cell is optional. The default is ":cell t", meaning the Cells engine will manage the slot to give
+it the spreadsheet-like characteristics. Specifying NIL signifies that this slot is entirely 
 outside any handling by the Cells engine; it is just a plain CLOS slot. 
 
-Specifying :ephemeral causes the Cells engine to reset the apparent slot 
+This next bit will not make sense until we have explained propagation of state change, but
+specifying :ephemeral causes the Cells engine to reset the apparent slot 
 value to NIL immediately and only after fully propagating any value assumed by the slot, either
 by assignment to an input Cell (the vastly more common case) or by a rule calculation.
 
@@ -92,7 +93,7 @@
 both :cell nil and :unchanged-if.] If specified, the named function is a predicate
 of two arguments, the new and old value in that order. The predicate determines if a subsequent
 slot value (either computed or assigned to an input) is unchanged in the sense that no propagation
-is necessary, either to dependent ruled cells or (getting ahead of ourselves) "on change" observers.
+is necessary, either to dependent ruled cells or (getting ahead of ourselves again) "on change" observers.
 The default unchanged test is EQL.
 
 Cell types
@@ -111,9 +112,9 @@
 yet grow based on text length and relevant font metrics to always leave room for one more character 
 (if the GUI design calls for that).
 
-To summarize, the class specification supplied with DEFMODEL specifies whether a slot can ever
-be managed by the Cells engine. For those that can, at and only at instance initialization time,
-different instances can have different Cell types mediating the same slot.
+To summarize, the class specification supplied with DEFMODEL specifies whether a slot can /ever/
+be managed by the Cells engine. For those that can, at and only at instance initialization time
+different instances can have different Cell types and rules specified to mediate the same slot.
 
 Input Cells
 -----------
@@ -121,7 +122,7 @@
 get data from the world outside the model -- it cannot be rules all the way down. Typically, these
 input assignements are made by code polling OS events via some GetNextEvent API call, or by callbacks
 registered with an event system such as win32 WindowProc functions. Other code may poll sockets or 
-serial inputs from some external device.
+serial inputs from an external device.
 
 Ruled Cells
 -----------
@@ -161,7 +162,7 @@
 we no longer know who else to update in light of such variation. The optimization, by the way, extends to
 eliminating ruled Cells which, after any computation, end up not depending on any other cell.
 
-Again, note that this is different than specifying ":cell nil" for some slot. Here, the Cells engine
+Again, note that this is different from specifying ":cell nil" for some slot. Here, the Cells engine
 has been told to manage some slot, but for some instance the slot has been authored to bear some value
 for the lifetime of that instance.
 
@@ -248,6 +249,32 @@
 the class designer when they decide to add a slot to a class. As instances are created and different rules
 specified for different slots to achieve custom behavior, the effort is the same as for the VisiCalc user.
 
+Model Building
+--------------
+Everything above could describe one instance of one class defined by DEFMODEL. Of course, we want multiples
+of both. In brief:
+
+-- cells can depend on other cells from any other instance. Since a rule gets passed only "self", Cell users
+need something like the Family class included with the Cells package effectively to turn a collection of
+instances into a network searchable by name or type.
+
+-- The overall model population must be maintainable by Cell slots such as the "kids" slot of the Family 
+class. The burden here is on the Cells engine to allow one cell of one child to ask for the value of a cell of
+another child and vice versa (with different Cells), when both children are the product of the same rule, 
+or different rules when "cousins" are exchanging information. So we must gracefully traverse the parent/kids 
+tree dispatching kids rules just in time to produce the other instance sought.
+
+-- kid-slotting: used almost exclusively so far for orderly GUI layout, a parent must be able to specify 
+rules for specific slots of kids. Example: a "stack" class wants to provide rules for child geometry
+specifying left, right, or centered alignment and vertical stacking (with optional spacing) one below 
+the other. The idea is that we want to other child instances without worrying about how they will
+be arranged in some container.
+
+-- finalization: when an instance appears in the "old kids" but not in the "new kids", a Cells engine
+may need to arrange for all Cells to "unsubscribe" from their dependents. Cells takes care of that if
+one calls "not-to-be" on an instance.
+
+
 Suggested Applications
 ----------------------
 Any application that must maintain an interesting, long-lived data model incorporating a stream of unpredictable 
@@ -508,3 +535,5 @@
 11. Weak Notification
    Automatically created inter-cell links must not inhibit garbage
 collection of either cell.  (Technically optional, but very easy to do.)
+
+
--- /project/cells/cvsroot/cells/cells.lpr	2006/06/25 21:30:34	1.16
+++ /project/cells/cvsroot/cells/cells.lpr	2006/06/29 09:54:06	1.17
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 
--- /project/cells/cvsroot/cells/family.lisp	2006/06/13 05:05:12	1.8
+++ /project/cells/cvsroot/cells/family.lisp	2006/06/29 09:54:06	1.9
@@ -46,8 +46,10 @@
     (unless (md-name self)
       (setf (md-name self) (gentemp (string (c-class-name (class-of self)))))))
  
-  (when (fm-parent self)
-    (md-be-adopted self)))
+  (when (and (slot-boundp self '.fm-parent)
+          (fm-parent self)
+          (zerop (adopt-ct self)))
+      (md-be-adopted self)))
 
 (defmodel perishable ()
   ((expiration :initform nil :accessor expiration :initarg :expiration)))
--- /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/25 21:30:34	1.23
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/29 09:54:06	1.24
@@ -81,8 +81,15 @@
              (return-from calculate-and-set))
            
            (when (find c *call-stack*) ;; circularity
+             (trc "cell appears in call stack:" c)
+             (loop with caller-reiterated
+                   for caller in *call-stack*
+                   until caller-reiterated
+                   do (trc "caller:" caller)
+                   (pprint (cr-code c))
+                   (setf caller-reiterated (eq caller c)))
              (c-break ;; break is problem when testing cells on some CLs
-              "cell ~a midst askers: ~a" c *call-stack*))
+              "cell ~a midst askers (see above)" c))
   
            (multiple-value-bind (raw-value propagation-code)
                (calculate-and-link c)
--- /project/cells/cvsroot/cells/model-object.lisp	2006/06/23 01:04:56	1.8
+++ /project/cells/cvsroot/cells/model-object.lisp	2006/06/29 09:54:06	1.9
@@ -45,21 +45,22 @@
   ; here we shuttle cells out of the slots and into a per-instance dictionary of cells,
   ; as well as tell the cells what slot and instance they are mediating.
   ;
-  (loop for esd in (class-slots (class-of self))
-      for sn = (slot-definition-name esd)
-      for sv = (when (slot-boundp self sn)
-                 (slot-value self sn))
-      ;;do (print (list self sn sv (typep sv 'cell)))
-      when (typep sv 'cell)
-      do (if (md-slot-cell-type (type-of self) sn)
-             (md-install-cell self sn sv)
-           (when *c-debug*
-             (trc "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv self sn))))
-  ;
-  ; queue up for awakening
-  ;
-  (with-integrity (:awaken self)
-    (md-awaken self)))
+  (when (slot-boundp self '.md-state)
+    (loop for esd in (class-slots (class-of self))
+        for sn = (slot-definition-name esd)
+        for sv = (when (slot-boundp self sn)
+                   (slot-value self sn))
+          ;;do (print (list self sn sv (typep sv 'cell)))
+        when (typep sv 'cell)
+        do (if (md-slot-cell-type (type-of self) sn)
+               (md-install-cell self sn sv)
+             (when *c-debug*
+               (trc "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv self sn))))
+    ;
+    ; queue up for awakening
+    ;
+    (with-integrity (:awaken self)
+      (md-awaken self))))
 
 (defun md-install-cell (self sn c &aux (c-isa-cell (typep c 'cell)))
   ;



From ktilton at common-lisp.net  Thu Jun 29 09:54:06 2006
From: ktilton at common-lisp.net (ktilton)
Date: Thu, 29 Jun 2006 05:54:06 -0400 (EDT)
Subject: [cells-cvs] CVS cells/gui-geometry
Message-ID: <20060629095406.A5BDD6200B@common-lisp.net>

Update of /project/cells/cvsroot/cells/gui-geometry
In directory clnet:/tmp/cvs-serv28230/gui-geometry

Modified Files:
	geo-data-structures.lisp geo-family.lisp gui-geometry.lpr 
Log Message:


--- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp	2006/06/20 14:16:45	1.2
+++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp	2006/06/29 09:54:06	1.3
@@ -27,7 +27,7 @@
 (instance-slots (mkv2 1 2))
 
 (defmethod print-object ((self v2) s)
-  (format s "(~a ~a)" (v2-h self)(v2-v self)))
+  (format s "~a|~a" (v2-h self)(v2-v self)))
 
 (defun mkv2 (h v) (make-v2 :h h :v v))
 
@@ -36,17 +36,27 @@
     (= (v2-h a)(v2-h b))
     (= (v2-v a)(v2-v b))))
 
-(defun v2-add (p1 p2)
-  (make-v2 :h (+ (v2-h p1) (v2-h p2))
-    :v (+ (v2-v p1) (v2-v p2))))
-
-(defun v2-move (p1 x y)
-  (make-v2 :h (+ (v2-h p1) x)
-    :v (+ (v2-v p1) y)))
-
-(defun v2-subtract (p1 p2)
-  (make-v2 :h (- (v2-h p1) (v2-h p2))
-    :v (- (v2-v p1) (v2-v p2))))
+(defun v2-add (p1 p2-or-x &optional y-or-p2-or-x-is-p2)
+  (if y-or-p2-or-x-is-p2
+      (make-v2 :h (+ (v2-h p1) p2-or-x)
+        :v (+ (v2-v p1) y-or-p2-or-x-is-p2))
+      (make-v2 :h (+ (v2-h p1) (v2-h p2-or-x))
+        :v (+ (v2-v p1) (v2-v p2-or-x)))))
+
+(defun v2-subtract (p1 p2-or-x &optional y-or-p2-or-x-is-p2)
+  (if y-or-p2-or-x-is-p2
+      (make-v2 :h (- (v2-h p1) p2-or-x)
+        :v (- (v2-v p1) y-or-p2-or-x-is-p2))
+      (make-v2 :h (- (v2-h p1) (v2-h p2-or-x))
+        :v (- (v2-v p1) (v2-v p2-or-x)))))
+
+(defun v2-nmove (p1 x &optional y)
+  (if y
+      (progn
+        (incf (v2-h p1) x)
+        (incf (v2-v p1) y))
+    (v2-move p1 (v2-h x)(v2-v x)))
+  p1)
 
 (defun v2-in-rect (v2 r)
   (mkv2 (min (r-right r) (max (r-left r) (v2-h v2)))
--- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp	2006/06/25 21:30:34	1.3
+++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp	2006/06/29 09:54:06	1.4
@@ -16,6 +16,9 @@
 
 (in-package :gui-geometry)
 
+(eval-when (compile load eval)
+  (export '(geo-inline-lazy)))
+
 ;--------------- geo-inline -----------------------------
 ;
 
@@ -55,6 +58,42 @@
                                    (c? (px-maintain-pl
                                         (^prior-sib-pr self (spacing .parent)))))))))))
 
+(defmodel geo-inline-lazy (geo-zero-tl)
+  ((orientation :initarg :orientation :initform nil :accessor orientation
+     :documentation ":vertical (for a column) or :horizontal (row)")
+   (justify :initarg :justify :accessor justify
+     :initform (c_? (ecase (orientation self)
+                     (:vertical :left)
+                     (:horizontal :top))))
+   (spacing :initarg :spacing :initform 0 :accessor spacing))
+  (:default-initargs
+      :lr (c_? (+ (^outset)
+                (ecase (orientation self)
+                  (:vertical (loop for k in (^kids)
+                                 maximizing (l-width k)))
+                  (:horizontal (bif (lk (last1 (^kids)))
+                                 (pr lk) 0)))))
+    :lb (c_? (+ (downs (^outset))
+              (ecase (orientation self)
+                (:vertical (bif (lk (last1 (^kids)))
+                             (pb lk) 0))
+                (:horizontal (downs (loop for k in (^kids)
+                                        maximizing (l-height k)))))))
+    :kid-slots (lambda (self)
+                 (ecase (orientation .parent)
+                   (:vertical (list
+                               (mk-kid-slot (px :if-missing t)
+                                 (c_? (^px-self-centered (justify .parent))))
+                               (mk-kid-slot (py)
+                                 (c_? (py-maintain-pt
+                                      (^prior-sib-pb self (spacing .parent)))))))
+                   (:horizontal (list
+                                 (mk-kid-slot (py :if-missing t)
+                                   (c_? (^py-self-centered (justify .parent))))
+                                 (mk-kid-slot (px)
+                                   (c_? (px-maintain-pl
+                                        (^prior-sib-pr self (spacing .parent)))))))))))
+
 
 #| archive
 
--- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr	2006/06/25 21:30:34	1.2
+++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr	2006/06/29 09:54:06	1.3
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 



From ktilton at common-lisp.net  Thu Jun 29 09:54:06 2006
From: ktilton at common-lisp.net (ktilton)
Date: Thu, 29 Jun 2006 05:54:06 -0400 (EDT)
Subject: [cells-cvs] CVS cells/utils-kt
Message-ID: <20060629095406.D78366200B@common-lisp.net>

Update of /project/cells/cvsroot/cells/utils-kt
In directory clnet:/tmp/cvs-serv28230/utils-kt

Modified Files:
	utils-kt.lpr 
Log Message:


--- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr	2006/06/23 01:04:57	1.12
+++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr	2006/06/29 09:54:06	1.13
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 



From ktilton at common-lisp.net  Thu Jun 29 09:54:53 2006
From: ktilton at common-lisp.net (ktilton)
Date: Thu, 29 Jun 2006 05:54:53 -0400 (EDT)
Subject: [cells-cvs] CVS Celtk
Message-ID: <20060629095453.081AB6303A@common-lisp.net>

Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv28373

Modified Files:
	CELTK.lpr Celtk.lisp button.lisp composites.lisp demos.lisp 
	run.lisp tk-object.lisp togl.lisp widget.lisp 
Log Message:


--- /project/cells/cvsroot/Celtk/CELTK.lpr	2006/06/07 22:13:41	1.16
+++ /project/cells/cvsroot/Celtk/CELTK.lpr	2006/06/29 09:54:52	1.17
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 
@@ -35,9 +35,7 @@
   :projects (list (make-instance 'project-module :name
                                  "..\\cells\\cells")
                   (make-instance 'project-module :name
-                                 "C:\\1-devtools\\cffi\\cffi")
-                  (make-instance 'project-module :name
-                                 "..\\Cells\\gui-geometry\\gui-geometry"))
+                                 "C:\\1-devtools\\cffi\\cffi"))
   :libraries nil
   :distributed-files nil
   :internally-loaded-files nil
--- /project/cells/cvsroot/Celtk/Celtk.lisp	2006/06/11 13:31:32	1.31
+++ /project/cells/cvsroot/Celtk/Celtk.lisp	2006/06/29 09:54:52	1.32
@@ -16,7 +16,7 @@
 
 |#
 
-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.31 2006/06/11 13:31:32 ktilton Exp $
+;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.32 2006/06/29 09:54:52 ktilton Exp $
 
 (defpackage :celtk
   (:nicknames "CTK")
@@ -52,6 +52,9 @@
 
 (in-package :Celtk)
 
+#+(and allegrocl ide (not runtime-system))
+(ide::defdefiner defcallback defun)
+
 (defvar *tki* nil)
 (defparameter *windows-being-destroyed* nil)
 (defparameter *windows-destroyed* nil)
@@ -135,7 +138,7 @@
       (let ((yes '())
             (no  '("font")))
         (declare (ignorable yes no))
-        (when t #+not (and (or ;; (null yes)
+        (when #+not t (and (or ;; (null yes)
                      (find-if (lambda (s) (search s tk$)) yes))
                 (not (find-if (lambda (s) (search s tk$)) no)))
           (format t "~&tk> ~a~%" tk$)))
--- /project/cells/cvsroot/Celtk/button.lisp	2006/05/24 20:38:54	1.4
+++ /project/cells/cvsroot/Celtk/button.lisp	2006/06/29 09:54:52	1.5
@@ -18,10 +18,6 @@
 
 (in-package :Celtk)
 
-(defcallback foo :int ((a :int) (b :int))
-   (declare (ignore b))
-   a)
-
 ;--- button ----------------------------------------------
 
 (deftk button (commander widget)
--- /project/cells/cvsroot/Celtk/composites.lisp	2006/06/03 12:04:37	1.10
+++ /project/cells/cvsroot/Celtk/composites.lisp	2006/06/29 09:54:52	1.11
@@ -70,7 +70,7 @@
   ((kids-packing :initarg :kids-packing :accessor kids-packing :initform nil)))
 
 (eval-when (compile load eval)
-  (export '(title$ active)))
+  (export '(title$ active .time)))
 
 (defvar *app*)
 
@@ -79,28 +79,28 @@
      :initarg :app-time
      :accessor app-time)))
 
+(define-symbol-macro .time (app-time *app*))
+
 (defmethod path ((self application)) nil)
 
 (defun app-idle (self)
-  (setf (^app-time) (now)))
+  (setf (^app-time) (get-internal-real-time)))
 
-(defmodel window (composite-widget)
-  ((title$ :initarg :title$ :accessor title$
-      :initform (c? (string-capitalize (class-name (class-of self)))))
-    (dictionary :initarg :dictionary :initform (make-hash-table :test 'equalp) :accessor dictionary)
-    (tkwins :initform (make-hash-table) :reader tkwins)
-    (xwins :initform (make-hash-table) :reader xwins)
-    (keyboard-modifiers :initarg :keyboard-modifiers :initform (c-in nil) :accessor keyboard-modifiers)
-    (callbacks :initarg :callbacks :accessor callbacks
-      :initform (make-hash-table :test #'eq))
-    (edit-style :initarg :edit-style :accessor edit-style :initform (c-in nil))
-    (tk-scaling :initarg :tk-scaling :accessor tk-scaling
-      :initform (c? 1.3 #+tki (read-from-string (tk-eval "tk scaling"))))
-    (tkfonts-to-load :initarg :tkfonts-to-load :accessor tkfonts-to-load :initform nil)
-    (tkfont-sizes-to-load :initarg :tkfont-sizes-to-load :accessor tkfont-sizes-to-load :initform nil)
-    (tkfont-info :initarg :tkfont-info :accessor tkfont-info
-      :initform (tkfont-info-loader))
-    (initial-focus :initarg :initial-focus :accessor initial-focus :initform nil)))
+(defmd window (composite-widget)
+  (title$ (c? (string-capitalize (class-name (class-of self)))))
+  (dictionary (make-hash-table :test 'equalp))
+  (tkwins (make-hash-table))
+  (xwins (make-hash-table))
+  (keyboard-modifiers (c-in nil))
+  (callbacks (make-hash-table :test #'eq))
+  (edit-style (c-in nil))
+  (tk-scaling (c? 1.3 #+tki (read-from-string (tk-eval "tk scaling"))))
+  tkfonts-to-load
+  tkfont-sizes-to-load
+  (tkfont-info (tkfont-info-loader))
+  initial-focus
+  on-key-down
+  on-key-up)
 
 (defobserver initial-focus ()
   (when new-value
--- /project/cells/cvsroot/Celtk/demos.lisp	2006/06/07 22:13:41	1.22
+++ /project/cells/cvsroot/Celtk/demos.lisp	2006/06/29 09:54:52	1.23
@@ -35,7 +35,7 @@
   (:default-initargs
       :kids (c? (the-kids                
                  (mk-label :text "hi, Mom"
-                   :px 100
+                   :parent-x 100
                    :py 20)))))
 
 (defmodel one-button-window (window)
--- /project/cells/cvsroot/Celtk/run.lisp	2006/06/07 22:13:41	1.16
+++ /project/cells/cvsroot/Celtk/run.lisp	2006/06/29 09:54:52	1.17
@@ -23,10 +23,11 @@
 (eval-when (compile load eval)
   (export '(tk-scaling run-window test-window)))
 
-(defun run-window (root-class)
+(defun run-window (root-class &optional (resetp t))
   (declare (ignorable root-class))
   (setf *tkw* nil)
-  (cells-reset 'tk-user-queue-handler)
+  (when resetp
+    (cells-reset 'tk-user-queue-handler))
   (tk-interp-init-ensure)
 
   (setf *tki* (Tcl_CreateInterp))
@@ -34,7 +35,13 @@
   (tk-app-init *tki*)
   (tk-togl-init *tki*)
   (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <<trace>> -data $op}")
+  
   (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) (null-pointer) (null-pointer))
+
+  ;; these next exist because of limitations in the Tcl API. eg, the keypress event does not
+  ;; include enough info to extract the keysym directly, and the function to extract the
+  ;; keysym is not exposed. The keysym, btw, is the portable representation of key events.
+
   (tcl-create-command *tki* "do-key-down" (get-callback 'do-on-key-down) (null-pointer) (null-pointer))
   (tcl-create-command *tki* "do-key-up" (get-callback 'do-on-key-up) (null-pointer) (null-pointer))
 
@@ -46,13 +53,15 @@
                                  :fm-parent *parent*)))))))
 
   (assert (tkwin *tkw*))
-
-  (tk-create-event-handler-ex *tkw* 'main-window-proc -1)
   
   (tk-format `(:fini) "wm deiconify .")
   (tk-format-now "bind . <Escape> {destroy .}")
+  ;
+  ; see above for why we are converting key x-events to application key virtual events:
+  ;
   (tk-format-now "bind . <KeyPress> {do-key-down %W %K}")
   (tk-format-now "bind . <KeyRelease> {do-key-up %W %K}")
+
   (tcl-do-one-event-loop))
 
 (defun ensure-destruction (w)
@@ -76,10 +85,9 @@
 (defun keysym-to-modifier (keysym)
   (gethash keysym *keyboard-modifiers*))
 
-(defcallback main-window-proc :void  ((client-data :pointer)(xe :pointer))
-  (let ((*tkw* (tkwin-widget client-data)))
-    (assert (typep *tkw* 'window))
-    (TRC nil "main window event" (xevent-type xe))
+(defmethod widget-event-handle ((self window) xe)
+  (let ((*tkw* self))
+    (TRC nil "main window event" *tkw* (xevent-type xe))
     (flet ((give-to-window ()
              (bwhen (eh (event-handler *tkw*))
                (funcall eh *tkw* xe))))
@@ -94,7 +102,9 @@
            (trc nil "main-window-proc :" n$ (unless (null-pointer-p (xsv user-data xe))
                                               (tcl-get-string (xsv user-data xe))))
            (case (read-from-string (string-upcase n$))
-             (keypress (let ((keysym (tcl-get-string (xsv user-data xe))))
+             (keypress (trc "going after keysym")
+               (let ((keysym (tcl-get-string (xsv user-data xe))))
+                         (trc "keypress keysym!!!!" (tcl-get-string (xsv user-data xe)))
                          (bIf (mod (keysym-to-modifier keysym))
                            (eko ("modifiers now")
                              (pushnew mod (keyboard-modifiers *tkw*)))
@@ -122,8 +132,8 @@
 
 (defun tcl-do-one-event-loop ()
   (loop while (plusp (tk-get-num-main-windows))
-      do (loop until (zerop (Tcl_DoOneEvent 2))
-             do (app-idle *app*)) ;; 2== TCL_DONT_WAIT
+      do (loop until (zerop (Tcl_DoOneEvent 2)) ;; 2== TCL_DONT_WAIT
+             do (app-idle *app*))
         (app-idle *app*)
         (sleep *event-loop-delay*) ;; give the IDE a few cycles
       finally
@@ -133,7 +143,7 @@
 
 (defmethod window-idle ((self window)))
 
-(defun test-window (root-class)
+(defun test-window (root-class &optional (resetp t))
   "nails existing window as a convenience in iterative development"
   (declare (ignorable root-class))
 
@@ -144,7 +154,7 @@
     (force-output *tkw*)
     (setf *tkw* nil))
 
-  (run-window root-class))
+  (run-window root-class resetp))
 
 ;;; --- commands -----------------------------------------------------------------
 
@@ -163,7 +173,9 @@
                (args (loop for argn upfrom 1 below argc
                          collecting (mem-aref argv :string argn))))
            (bif (self (gethash (car args) (dictionary *tkw*)))
-             (apply ',do-on-name self (rest args))
+             (progn
+               (trc nil "defcommand > " ',^on-name self (cdr args))
+               (apply ',do-on-name self (rest args)))
              (progn
                (break ",do-on-name> Target widget ~a does not exist" (car args))
                #+anyvalue? (tcl-set-result interp
@@ -172,6 +184,9 @@
                1)))))))
 
 (defcommand command)
-(defcommand key-up)
+;
+; see notes elsewhere for why Tcl API deficiencies require augmented key handling via app virtual events
+;
 (defcommand key-down)
+(defcommand key-up)
 
--- /project/cells/cvsroot/Celtk/tk-object.lisp	2006/06/07 22:13:41	1.6
+++ /project/cells/cvsroot/Celtk/tk-object.lisp	2006/06/29 09:54:52	1.7
@@ -27,7 +27,9 @@
    
    (timers :initarg :timers :accessor timers :initform nil)
    (on-command :initarg :on-command :accessor on-command :initform nil)
-   (on-key-down :initarg :on-key-down :accessor on-key-down :initform nil)
+   (on-key-down :initarg :on-key-down :accessor on-key-down :initform nil
+     :documentation "Long story. Tcl C API sucks for keypress events. This gets dispatched
+eventually thanks to DEFCOMMAND")
    (on-key-up :initarg :on-key-up :accessor on-key-up :initform nil)
    (user-errors :initarg :user-errors :accessor user-errors :initform nil))
   (:documentation "Root class for widgets and (canvas) items"))
--- /project/cells/cvsroot/Celtk/togl.lisp	2006/06/11 13:31:32	1.10
+++ /project/cells/cvsroot/Celtk/togl.lisp	2006/06/29 09:54:52	1.11
@@ -71,7 +71,7 @@
 ;; Togl_DumpToEpsFile
 
 (eval-when (compile load eval)
-  (export '(with-togl togl-interp togl-swap-buffers togl-post-redisplay togl-ptr togl-reshape-func
+  (export '(togl with-togl togl-interp togl-swap-buffers togl-post-redisplay togl-ptr togl-reshape-func
              togl togl-timer-using-class togl-post-redisplay togl-reshape-using-class
              togl-display-using-class togl-width togl-height togl-create-using-class)))
 
--- /project/cells/cvsroot/Celtk/widget.lisp	2006/06/11 13:31:32	1.14
+++ /project/cells/cvsroot/Celtk/widget.lisp	2006/06/29 09:54:52	1.15
@@ -55,8 +55,8 @@
    (xwin :cell nil :accessor xwin :initform nil)
    (packing :reader packing :initarg :packing :initform nil)
    (gridding :reader gridding :initarg :gridding :initform nil)
-   (px :reader px :initarg :px :initform nil)
-   (py :reader py :initarg :py :initform nil)
+   (parent-x :reader parent-x :initarg :parent-x :initform nil)
+   (parent-y :reader parent-y :initarg :parent-y :initform nil)
    (relx :reader relx :initarg :relx :initform nil)
    (rely :reader rely :initarg :rely :initform nil)
    (enabled :reader enabled :initarg :enabled :initform t)
@@ -69,7 +69,7 @@
   (:default-initargs
       :id (gentemp "W")
     :event-handler nil #+debug (lambda (self xe)
-                                 (TRC "widget-event-handler" self (tk-event-type (xsv type xe))))))
+                                 (TRC "debug event handler" self (tk-event-type (xsv type xe))))))
 
 (eval-when (compile load eval)
   (export '()))
@@ -110,20 +110,21 @@
     (tkwin-register self)
     (tk-create-event-handler-ex self 'widget-event-handler-callback -1)))
 
-(defobserver px ((self widget))
+(defobserver parent-x ((self widget))
   (unless (typep self 'window)
     (when new-value
       (tk-format `(:grid ,self) ;; placing is like grid for this sort
         "place ~a ~a -x ~a -y ~a" (if old-value "configure" "")
-        (^path) new-value (^py)))))
+        (^path) new-value (^parent-y)))))
 
 (defcallback widget-event-handler-callback :void  ((client-data :pointer)(xe :pointer))
-  (let ((self (tkwin-widget client-data)))
-    (assert self () "widget-event-handler > no widget for tkwin ~a" client-data)
-    (widget-event-handle self xe)))
+  (bif (self (tkwin-widget client-data))
+    (widget-event-handle self xe)
+    ;; sometimes I hit the next branch restarting after crash....
+    (trc "widget-event-handler > no widget for tkwin ~a" client-data)))
 
-(defmethod widget-event-handle ((self widget) xe)
-  (bif (h (^event-handler))
+(defmethod widget-event-handle ((self widget) xe) ;; override for class-specific handling
+  (bif (h (^event-handler)) ;; support instance-specific handlers
     (funcall h self xe)
     #+shhh (case (xevent-type xe)
       (:buttonpress