From ktilton at common-lisp.net  Mon Jul  3 00:08:29 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sun,  2 Jul 2006 20:08:29 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060703000829.302241400F@common-lisp.net>

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

Modified Files:
	defmodel.lisp link.lisp 
Log Message:


--- /project/cells/cvsroot/cells/defmodel.lisp	2006/06/23 01:04:56	1.6
+++ /project/cells/cvsroot/cells/defmodel.lisp	2006/07/03 00:08:29	1.7
@@ -100,7 +100,6 @@
                            )
                       (setf (md-slot-cell-type class slotname) cell)
                       
-                      
                       `(progn
                          ,(when reader-fn
                             `(defmethod ,reader-fn ((self ,class))
@@ -173,7 +172,7 @@
                                        :accessor spec) slots)))
              finally
                (return (list* (nreverse slots)
-                         (delete-if 'null
+                         (delete nil
                            (list* `(:default-initargs , at definitargs)
                              (nreverse class-options)))))))))
 
--- /project/cells/cvsroot/cells/link.lisp	2006/06/23 01:04:56	1.13
+++ /project/cells/cvsroot/cells/link.lisp	2006/07/03 00:08:29	1.14
@@ -76,7 +76,7 @@
                          (handle-used (incf rev-pos)))
                      (handle-used (setf rev-pos 0))))))
         (nail-unused (cd-useds c))
-        (setf (cd-useds c) (delete-if #'null (cd-useds c)))))))
+        (setf (cd-useds c) (delete nil (cd-useds c)))))))
 
 (defun c-caller-path-exists-p (from-used to-caller)
   (count-it :caller-path-exists-p)



From ktilton at common-lisp.net  Mon Jul  3 00:08:29 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sun,  2 Jul 2006 20:08:29 -0400 (EDT)
Subject: [cells-cvs] CVS cells/gui-geometry
Message-ID: <20060703000829.7679916008@common-lisp.net>

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

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


--- /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp	2006/06/23 01:04:57	1.5
+++ /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp	2006/07/03 00:08:29	1.6
@@ -21,7 +21,7 @@
     #: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
+    #:mkr #:v2-nmove #:l-height #:mkv2 #:^offset-within #:inset-lr #:v2-v #:v2-h
     #:r-bounds #:l-box
     #:lb
     #:cs-target-res 
--- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp	2006/06/29 09:54:06	1.3
+++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp	2006/07/03 00:08:29	1.4
@@ -16,6 +16,8 @@
 
 (in-package :gui-geometry)
 
+(eval-when (compile load eval)
+  (export '(v2)))
 ;-----------------------------
 
 (defstruct v2 
@@ -55,7 +57,7 @@
       (progn
         (incf (v2-h p1) x)
         (incf (v2-v p1) y))
-    (v2-move p1 (v2-h x)(v2-v x)))
+    (v2-nmove p1 (v2-h x)(v2-v x)))
   p1)
 
 (defun v2-in-rect (v2 r)
--- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp	2006/06/29 09:54:06	1.4
+++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp	2006/07/03 00:08:29	1.5
@@ -21,7 +21,6 @@
 
 ;--------------- geo-inline -----------------------------
 ;
-
 (defmodel geo-inline (geo-zero-tl)
   ((orientation :initarg :orientation :initform nil :accessor orientation
      :documentation ":vertical (for a column) or :horizontal (row)")
@@ -37,7 +36,7 @@
                                  maximizing (l-width k)))
                   (:horizontal (bif (lk (last1 (^kids)))
                                  (pr lk) 0)))))
-    :lb (c? (+ (downs (^outset))
+    :lb (c? (+ (- (^outset))
               (ecase (orientation self)
                 (:vertical (bif (lk (last1 (^kids)))
                              (pb lk) 0))
@@ -73,7 +72,7 @@
                                  maximizing (l-width k)))
                   (:horizontal (bif (lk (last1 (^kids)))
                                  (pr lk) 0)))))
-    :lb (c_? (+ (downs (^outset))
+    :lb (c_? (+ (- (^outset))
               (ecase (orientation self)
                 (:vertical (bif (lk (last1 (^kids)))
                              (pb lk) 0))
@@ -85,8 +84,10 @@
                                (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)))))))
+                                 (c_? (eko (nil "py" self (^lt) (l-height self)(psib))
+                                        (py-maintain-pt
+                                         (eko (nil "psib-pb")
+                                           (^prior-sib-pb self (spacing .parent)))))))))
                    (:horizontal (list
                                  (mk-kid-slot (py :if-missing t)
                                    (c_? (^py-self-centered (justify .parent))))
--- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp	2006/06/23 01:04:57	1.4
+++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp	2006/07/03 00:08:29	1.5
@@ -16,19 +16,16 @@
 
 (in-package #:gui-geometry)
 
-(defmodel geometer ()
-  ((inset :cell nil :initarg :inset :reader inset
-      :unchanged-if 'v2= :initform (mkv2 0 0))
-   (outset :initarg :outset :initform 0 :accessor outset)
-   (collapsed :initarg :collapsed :initform nil :accessor collapsed)
-   (px :initarg :px :initform nil :accessor px)
-   (py :initarg :py :initform nil :accessor py)
-   (ll :initarg :ll :initform nil :accessor ll)
-   (lt :initarg :lt :initform nil :accessor lt)
-   (lr :initarg :lr :initform nil :accessor lr)
-   (lb :initarg :lb :initform nil :accessor lb)
-   (w-box :cell nil :initform (mkr 0 0 0 0) :accessor w-box
-     :documentation "bbox in window coordinate system")))
+(eval-when (compile load eval)
+  (export '(outset ^outset)))
+
+(defmd geometer ()
+  px py ll lt lr lb
+  collapsed
+  (inset (mkv2 0 0) :unchanged-if 'v2=)
+  (outset 0)
+  (w-box (mkr 0 0 0 0) :cell nil :accessor w-box
+    :documentation "bbox in window coordinate system"))
 
 (defmethod collapsed (other)
   (declare (ignore other))
@@ -40,14 +37,14 @@
    ()
    (:default-initargs
     :ll (c? (- (outset self))) 
-    :lt (c? (ups (outset self))) 
+    :lt (c? (+ (outset self))) 
     :lr (c? (geo-kid-wrap self 'pr)) 
     :lb (c? (geo-kid-wrap self 'pb))
     :kid-slots (def-kid-slots
                    (mk-kid-slot (px :if-missing t)
                      (c? (px-maintain-pl 0)))
                    (mk-kid-slot (py :if-missing t)
-                     (c? (py-maintain-pt 0))))))
+                     (c? (break)(py-maintain-pt 0))))))
 
 (defmodel geo-kid-sized (family) 
     ()
@@ -206,7 +203,7 @@
    (- (lr self) (outset self)))
 
 (defun inset-lb (self)
-   (ups (lb self) (outset self)))
+   (+ (lb self) (outset self)))
 
 (defun inset-height (self)
    (- (l-height self) (outset self) (outset self)))
@@ -293,19 +290,14 @@
   `(c? (lr-maintain-pr (- (inset-lr .parent)
                             ,padding))))
 
-(defmacro ^prior-sib-pb (self &optional (spacing 0))
-   (let ((kid (gensym))
-         (psib (gensym)))
-      `(let* ((,kid ,self)
-               (,psib (find-prior ,kid (kids (fm-parent ,kid))
-                        :test (lambda (sib)
-                                (not (collapsed sib)))))
-               )
-          ;(trc "^priorSib-pb > kid, sib" ,kid ,pSib)
-          (if ,psib
-              (+ (- (abs ,spacing)) ;; force spacing to minus(= down for OpenGL)
-                (pb ,psib))
-            0))))
+(defun ^prior-sib-pb (self &optional (spacing 0))
+  (bif (psib (find-prior self (kids .parent)
+               :test (lambda (sib)
+                       (not (collapsed sib)))))
+    (eko (nil "^prior-sib-pb spc pb-psib -lt" (- (abs spacing)) (pb psib) (- (^lt)))
+      (+ (- (abs spacing)) ;; force spacing to minus(= down for OpenGL)
+        (pb psib)))   
+      0))
 
 (defmacro ^prior-sib-pt (self &optional (spacing 0))
    (let ((kid (gensym))



From ktilton at common-lisp.net  Mon Jul  3 00:08:29 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sun,  2 Jul 2006 20:08:29 -0400 (EDT)
Subject: [cells-cvs] CVS cells/utils-kt
Message-ID: <20060703000829.A88F816008@common-lisp.net>

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

Modified Files:
	flow-control.lisp 
Log Message:


--- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp	2006/05/20 06:32:20	1.3
+++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp	2006/07/03 00:08:29	1.4
@@ -55,7 +55,7 @@
     list))
 
 (defun packed-flat! (&rest u-nameit)
-   (delete-if #'null (list-flatten! u-nameit)))
+   (delete nil (list-flatten! u-nameit)))
 
 (defmacro with-dynamic-fn ((fn-name (&rest fn-args) &body fn-body) &body body)
   `(let ((,fn-name (lambda ,fn-args , at fn-body)))



From ktilton at common-lisp.net  Mon Jul  3 00:32:53 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sun,  2 Jul 2006 20:32:53 -0400 (EDT)
Subject: [cells-cvs] CVS Celtk
Message-ID: <20060703003253.168022D010@common-lisp.net>

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

Modified Files:
	Celtk.lisp composites.lisp run.lisp togl.lisp 
Log Message:


--- /project/cells/cvsroot/Celtk/Celtk.lisp	2006/06/29 09:54:52	1.32
+++ /project/cells/cvsroot/Celtk/Celtk.lisp	2006/07/03 00:32:52	1.33
@@ -16,12 +16,13 @@
 
 |#
 
-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.32 2006/06/29 09:54:52 ktilton Exp $
+;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.33 2006/07/03 00:32:52 ktilton Exp $
 
 (defpackage :celtk
   (:nicknames "CTK")
   (:use :common-lisp :utils-kt :cells :cffi)
   (:export
+   #:right #:left
    #:<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
@@ -45,7 +46,7 @@
    #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps
    #:^widget-menu #:widget-menu #:tk-format-now
    #:coords #:^coords #:tk-translate-keysym
-    #:*tkw*))
+   #:*tkw*))
 
 (defpackage :celtk-user
   (:use :common-lisp :utils-kt :cells :celtk))
--- /project/cells/cvsroot/Celtk/composites.lisp	2006/06/29 09:54:52	1.11
+++ /project/cells/cvsroot/Celtk/composites.lisp	2006/07/03 00:32:52	1.12
@@ -107,26 +107,28 @@
     (tk-format '(:fini new-value) "focus ~a" (path new-value))))
 
 (defun tkfont-info-loader ()
-    (c? (eko (nil "tkfinfo")
-          (loop with scaling = (^tk-scaling)
-              for (tkfont fname) in (^tkfonts-to-load)
-              collect (cons tkfont
-                        (apply 'vector
-                          (loop for fsize in (^tkfont-sizes-to-load)
-                                for id = (format nil "~(~a-~2,'0d~)" tkfont fsize)
-                              for tkf = (tk-eval "font create ~a -family {~a} -size ~a"
-                                          id fname fsize)
-                              for (nil ascent nil descent nil linespace nil fixed) = (tk-eval-list "font metrics ~a" tkf)
-                              collect (make-tkfinfo :ascent (round (parse-integer ascent) scaling)
-                                        :id id
-                                        :family fname
-                                        :size fsize
-                                        :descent (round (parse-integer descent) scaling)
-                                        :linespace (round (parse-integer linespace) scaling)
-                                        :fixed (plusp (parse-integer fixed))
-                                        :em (round (parse-integer
-                                                    (tk-eval "font measure ~(~a~) \"m\"" tkfont))
-                                              scaling)))))))))
+  (c? (eko (nil "tkfinfo")
+        (loop with scaling = (^tk-scaling)
+            for (tkfont fname) in (^tkfonts-to-load)
+            collect (cons tkfont
+                      (apply 'vector
+                        (loop for fsize in (^tkfont-sizes-to-load)
+                            for id = (format nil "~(~a-~2,'0d~)" tkfont fsize)
+                            for tkf = (tk-eval "font create ~a -family {~a} -size ~a"
+                                        id fname fsize)
+                            for (nil ascent nil descent nil linespace nil fixed) = (tk-eval-list "font metrics ~a" tkf)
+                            collect 
+                              (progn (trc nil "tkfontloaded" id fname fsize tkfont tkf)
+                                (make-tkfinfo :ascent (round (parse-integer ascent) scaling)
+                                  :id id
+                                  :family fname
+                                  :size fsize
+                                  :descent (round (parse-integer descent) scaling)
+                                  :linespace (round (parse-integer linespace) scaling)
+                                  :fixed (plusp (parse-integer fixed))
+                                  :em (round (parse-integer
+                                              (tk-eval "font measure ~(~a~) \"m\"" tkfont))
+                                        scaling))))))))))
 
 (defobserver title$ ((self window))
    (tk-format '(:configure "title") "wm title . ~s" (or new-value "Untitled")))
--- /project/cells/cvsroot/Celtk/run.lisp	2006/06/29 09:54:52	1.17
+++ /project/cells/cvsroot/Celtk/run.lisp	2006/07/03 00:32:52	1.18
@@ -23,7 +23,7 @@
 (eval-when (compile load eval)
   (export '(tk-scaling run-window test-window)))
 
-(defun run-window (root-class &optional (resetp t))
+(defun run-window (root-class &optional (resetp t) &rest window-initargs)
   (declare (ignorable root-class))
   (setf *tkw* nil)
   (when resetp
@@ -49,8 +49,10 @@
     (setf *app*
       (make-instance 'application
         :kids (c? (the-kids
-                   (setf *tkw* (make-instance root-class
-                                 :fm-parent *parent*)))))))
+                   (setf *tkw* (apply 'make-instance root-class
+                                 :fm-parent *parent*
+                                 window-initargs))))
+        )))
 
   (assert (tkwin *tkw*))
   
@@ -143,7 +145,7 @@
 
 (defmethod window-idle ((self window)))
 
-(defun test-window (root-class &optional (resetp t))
+(defun test-window (root-class &optional (resetp t) &rest window-initargs)
   "nails existing window as a convenience in iterative development"
   (declare (ignorable root-class))
 
@@ -154,7 +156,7 @@
     (force-output *tkw*)
     (setf *tkw* nil))
 
-  (run-window root-class resetp))
+  (apply 'run-window root-class resetp window-initargs))
 
 ;;; --- commands -----------------------------------------------------------------
 
--- /project/cells/cvsroot/Celtk/togl.lisp	2006/06/29 09:54:52	1.11
+++ /project/cells/cvsroot/Celtk/togl.lisp	2006/07/03 00:32:52	1.12
@@ -178,7 +178,9 @@
        (defmethod ,(intern uc$) ((self togl))))))
 
 (def-togl-callback create ()
-  (setf (togl-ptr self) togl-ptr)
+  (trc "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr self)
+  (setf (togl-ptr self) (setf cl-ftgl::*ftgl-ogl* ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready
+                          togl-ptr))
   (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))
 
 (def-togl-callback display ())



From ktilton at common-lisp.net  Mon Jul  3 01:31:38 2006
From: ktilton at common-lisp.net (ktilton)
Date: Sun,  2 Jul 2006 21:31:38 -0400 (EDT)
Subject: [cells-cvs] CVS Celtk
Message-ID: <20060703013138.2FCE91D007@common-lisp.net>

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

Modified Files:
	lotsa-widgets.lisp togl.lisp 
Log Message:


--- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp	2006/06/07 22:13:41	1.4
+++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp	2006/07/03 01:31:38	1.5
@@ -19,6 +19,15 @@
 
 (in-package :celtk-user)
 
+;;; Creates a pathname with NAME and TYPE in the same
+;;; directory/host/device/whatever as this lisp file. Tries to get
+;;; that at compile time to cope with some useful ASDF extensions that
+;;; place fasls in arbitrary places.
+(defun data-pathname (name type)
+  (merge-pathnames (make-pathname :name name :type type)
+                   #.(or *compile-file-truename* *load-truename*)))
+
+
 (defmodel lotsa-widgets (window)
   ()
   (:default-initargs
@@ -27,9 +36,7 @@
                  
                  (mk-row (:packing (c?pack-self))
                    (mk-label :text "aaa"
-                     :image-files (list (list 'kt (make-pathname #+lispworks :host #-lispworks :device "c"
-                                                    :directory '(:absolute "0dev" "Celtk")
-                                                    :name "kt69" :type "gif")))
+                     :image-files (list (list 'kt (data-pathname "kt69" "gif")))
                      :height 200
                      :width 300
                      :image (c? (format nil "~(~a.~a~)" (ctk::^path) 'kt)))
@@ -145,10 +152,7 @@
    :height 350
    :kids (c? (the-kids
               (mk-bitmap :coords (list 140 140)
-                :bitmap (conc$ "@" (namestring (make-pathname
-                                                :directory '(:absolute "0dev" "Celtk")
-                                                :name "x1"
-                                                :type "xbm"))))
+                :bitmap (conc$ "@" (namestring (data-pathname "x1" "xbm"))))
               (mk-rectangle :coords (list 10 10 100 60)
                 :tk-fill "red")
               (mk-text-item :coords (list 100 80)
--- /project/cells/cvsroot/Celtk/togl.lisp	2006/07/03 00:32:52	1.12
+++ /project/cells/cvsroot/Celtk/togl.lisp	2006/07/03 01:31:38	1.13
@@ -20,7 +20,8 @@
 
 
 (define-foreign-library Togl
-    (:darwin (:or "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib"))
+  (:darwin (:or "libTogl1.7.dylib"
+                "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib"))
   (:windows (:or "/tcl/lib/togl/togl17.dll"))
   (:unix "/usr/lib/Togl1.7/libTogl1.7.so"))
 



From ktilton at common-lisp.net  Thu Jul  6 22:10:02 2006
From: ktilton at common-lisp.net (ktilton)
Date: Thu,  6 Jul 2006 18:10:02 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060706221002.1251D13002@common-lisp.net>

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

Modified Files:
	cells.asd constructors.lisp family.lisp integrity.lisp 
	link.lisp synapse.lisp 
Log Message:


--- /project/cells/cvsroot/cells/cells.asd	2006/05/30 02:47:45	1.4
+++ /project/cells/cvsroot/cells/cells.asd	2006/07/06 22:10:01	1.5
@@ -30,7 +30,6 @@
                (:file "initialize")
                (:file "md-slot-value")
                (:file "slot-utilities")
-               (:file "optimization")
                (:file "link")
                (:file "propagate")
                (:file "model-object")
--- /project/cells/cvsroot/cells/constructors.lisp	2006/06/09 17:21:35	1.7
+++ /project/cells/cvsroot/cells/constructors.lisp	2006/07/06 22:10:01	1.8
@@ -18,7 +18,7 @@
 
 (in-package :cells)
 
-(eval-when (compile load eval)
+(eval-now!
   (export '(c?n)))
 
 ;___________________ constructors _______________________________
--- /project/cells/cvsroot/cells/family.lisp	2006/06/29 09:54:06	1.9
+++ /project/cells/cvsroot/cells/family.lisp	2006/07/06 22:10:01	1.10
@@ -141,7 +141,6 @@
                 (md-install-cell self slot-name c-or-value)))))))))
 
 (defobserver .kids ((self family) new-kids old-kids)
-  (declare (ignorable usage))
   (c-assert (listp new-kids) () "New kids value for ~a not listp: ~a ~a" self (type-of new-kids) new-kids)
   (c-assert (listp old-kids))
   (c-assert (not (member nil old-kids)))
--- /project/cells/cvsroot/cells/integrity.lisp	2006/06/23 01:04:56	1.10
+++ /project/cells/cvsroot/cells/integrity.lisp	2006/07/06 22:10:01	1.11
@@ -64,8 +64,7 @@
   (let ((*within-integrity* nil)
           *unfinished-business*
           *defer-changes*
-        *call-stack*
-        (*data-pulse-id* 0))
+        *call-stack*)
     (funcall action)))
 
 (defun ufb-queue (opcode)
--- /project/cells/cvsroot/cells/link.lisp	2006/07/03 00:08:29	1.14
+++ /project/cells/cvsroot/cells/link.lisp	2006/07/06 22:10:01	1.15
@@ -129,10 +129,3 @@
           ;(c.trc "its ruled" c)
           (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/synapse.lisp	2006/06/23 01:04:56	1.12
+++ /project/cells/cvsroot/cells/synapse.lisp	2006/07/06 22:10:01	1.13
@@ -22,7 +22,6 @@
   (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent)))
 
 (defmacro with-synapse (synapse-id (&rest closure-vars) &body body)
-  (declare (ignorable trcp))
   (let ((syn-id (gensym))(syn-caller (gensym)))
     `(let* ((,syn-id ,synapse-id)
             (,syn-caller (car *call-stack*))



From ktilton at common-lisp.net  Thu Jul  6 22:10:02 2006
From: ktilton at common-lisp.net (ktilton)
Date: Thu,  6 Jul 2006 18:10:02 -0400 (EDT)
Subject: [cells-cvs] CVS cells/cells-test
Message-ID: <20060706221002.49B3813001@common-lisp.net>

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

Modified Files:
	test-lazy.lisp 
Log Message:


--- /project/cells/cvsroot/cells/cells-test/test-lazy.lisp	2006/03/16 05:22:08	1.3
+++ /project/cells/cvsroot/cells/cells-test/test-lazy.lisp	2006/07/06 22:10:02	1.4
@@ -118,3 +118,24 @@
 
 #+(or) 
 (cv-test-lazy)
+
+(defparameter *lz1-count* 0)
+
+(defmd lz-simple ()
+  (lz1 (c?_ (incf *lz1-count*)
+          (* 2 (^lz2))))
+   (lz2 (c-in 0)))
+
+(defun lz-test ()
+  (cells-reset)
+  (let ((*lz1-count* 0)
+        (lz (make-instance 'lz-simple)))
+    (assert (zerop *lz1-count*))
+    (incf (lz2 lz))
+    (assert (zerop *lz1-count*))
+    (assert (= (lz1 lz) 2))
+    (assert (= 1 *lz1-count*))
+    lz))
+
+#+test
+(lz-test)



From ktilton at common-lisp.net  Thu Jul  6 22:10:02 2006
From: ktilton at common-lisp.net (ktilton)
Date: Thu,  6 Jul 2006 18:10:02 -0400 (EDT)
Subject: [cells-cvs] CVS cells/gui-geometry
Message-ID: <20060706221002.921C413001@common-lisp.net>

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

Modified Files:
	geo-data-structures.lisp geo-family.lisp geometer.lisp 
Added Files:
	gui-geometry.asd 
Log Message:


--- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp	2006/07/03 00:08:29	1.4
+++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp	2006/07/06 22:10:02	1.5
@@ -16,7 +16,7 @@
 
 (in-package :gui-geometry)
 
-(eval-when (compile load eval)
+(eval-now!
   (export '(v2)))
 ;-----------------------------
 
@@ -312,7 +312,7 @@
 
 ;;; --- Up / Down variability management ---
 
-(eval-when (compile load eval)
+(eval-now!
   (export '(*up-is-positive* ups ups-more ups-most downs downs-most downs-more)))
 
 (defparameter *up-is-positive* t
--- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp	2006/07/03 00:08:29	1.5
+++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp	2006/07/06 22:10:02	1.6
@@ -16,7 +16,7 @@
 
 (in-package :gui-geometry)
 
-(eval-when (compile load eval)
+(eval-now!
   (export '(geo-inline-lazy)))
 
 ;--------------- geo-inline -----------------------------
--- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp	2006/07/03 00:08:29	1.5
+++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp	2006/07/06 22:10:02	1.6
@@ -16,7 +16,7 @@
 
 (in-package #:gui-geometry)
 
-(eval-when (compile load eval)
+(eval-now!
   (export '(outset ^outset)))
 
 (defmd geometer ()

--- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.asd	2006/07/06 22:10:02	NONE
+++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.asd	2006/07/06 22:10:02	1.1
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-

(asdf:defsystem :gui-geometry
  :author "Kenny Tilton <kentilton at gmail.com>"
  :maintainer "Kenny Tilton <kentilton at gmail.com>"
  :licence "Lisp LGPL"
  :depends-on (:cells)
  :serial t
  :components
  ((:file "defpackage")
   (:file "geo-data-structures")
   (:file "coordinate-xform")
   (:file "geometer")
   (:file "geo-family")))


From ktilton at common-lisp.net  Thu Jul  6 22:10:03 2006
From: ktilton at common-lisp.net (ktilton)
Date: Thu,  6 Jul 2006 18:10:03 -0400 (EDT)
Subject: [cells-cvs] CVS cells/utils-kt
Message-ID: <20060706221003.D1FF11300D@common-lisp.net>

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

Modified Files:
	datetime.lisp detritus.lisp strings.lisp 
Log Message:


--- /project/cells/cvsroot/cells/utils-kt/datetime.lisp	2006/05/20 06:32:20	1.2
+++ /project/cells/cvsroot/cells/utils-kt/datetime.lisp	2006/07/06 22:10:03	1.3
@@ -19,8 +19,9 @@
 
 (in-package :utils-kt)
 
-(eval-when (compile load eval)
-  (export '(os-tickcount time-of-day now hour-min-of-day time-in-zone dd-mmm-yy mmm-dd-yyyy)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(os-tickcount time-of-day now hour-min-of-day
+            time-in-zone dd-mmm-yy mmm-dd-yyyy)))
 
 (defun os-tickcount ()
   (cl:get-internal-real-time))
@@ -74,8 +75,9 @@
     (format nil "~A ~A, ~A" (month-abbreviation month)
             date year)))
 
-(eval-when (compile load eval)
-  (export '(month-abbreviation weekday-abbreviation week-time mdyy-yymd u-time u-date)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(month-abbreviation weekday-abbreviation week-time
+            mdyy-yymd u-time u-date)))
 
 (defun month-abbreviation (month)
   (elt '("Jan" "Feb" "Mar" "Apr" "May" "June"
@@ -131,7 +133,7 @@
       year
       )))
 
-(eval-when (compile load eval)
+(eval-when (:compile-toplevel :load-toplevel :execute)
   (export '(u-day multiple-value-bind m/d/y mm/dd yyyy-mm-dd)))
 
 (defun u-day (&optional (i-time (get-universal-time)))
@@ -180,7 +182,7 @@
     (format nil "~4,,,'0 at A~2,,,'0 at A~2,,,'0 at A"
       year month date)))
 
-(eval-when (compile load eval)
+(eval-now!
   (export '(ymdhmsh)))
 
 (defun ymdhmsh (&optional (i-time (get-universal-time)))
--- /project/cells/cvsroot/cells/utils-kt/detritus.lisp	2006/05/20 06:32:20	1.6
+++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp	2006/07/06 22:10:03	1.7
@@ -19,10 +19,21 @@
 
 (in-package :utils-kt)
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(eval-now!)))
+
 (defmacro wdbg (&body body)
   `(let ((*dbg* t))
      , at body))
 
+(defmacro eval-now! (&body body)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     , at body))
+
+(defmacro export! (&rest symbols)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (export ',symbols)))
+
 ;;;(defmethod class-slot-named ((classname symbol) slotname)
 ;;;  (class-slot-named (find-class classname) slotname))
 ;;;
--- /project/cells/cvsroot/cells/utils-kt/strings.lisp	2006/05/20 06:32:20	1.4
+++ /project/cells/cvsroot/cells/utils-kt/strings.lisp	2006/07/06 22:10:03	1.5
@@ -19,7 +19,7 @@
 
 (in-package :utils-kt)
 
-(eval-when (compile load eval)
+(eval-when (:compile-toplevel :load-toplevel :execute)
   (export '(case$ strloc$  make$  space$  char$  conc-list$  conc$
              left$  mid$  seg$  right$  insert$  remove$
              trim$  trunc$  abbrev$  empty$ find$  num$



From ktilton at common-lisp.net  Thu Jul  6 22:10:41 2006
From: ktilton at common-lisp.net (ktilton)
Date: Thu,  6 Jul 2006 18:10:41 -0400 (EDT)
Subject: [cells-cvs] CVS Celtk
Message-ID: <20060706221041.2E6F024009@common-lisp.net>

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

Modified Files:
	Celtk.asd Celtk.lisp composites.lisp font.lisp run.lisp 
	timer.lisp tk-object.lisp togl.lisp widget.lisp 
Log Message:


--- /project/cells/cvsroot/Celtk/Celtk.asd	2006/06/07 22:13:41	1.10
+++ /project/cells/cvsroot/Celtk/Celtk.asd	2006/07/06 22:10:39	1.11
@@ -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 :gui-geometry)
+  :depends-on (:cells :cffi :gui-geometry :cl-ftgl)
   :serial t
   :components ((:file "Celtk")
                (:file "tk-structs")
--- /project/cells/cvsroot/Celtk/Celtk.lisp	2006/07/03 00:32:52	1.33
+++ /project/cells/cvsroot/Celtk/Celtk.lisp	2006/07/06 22:10:39	1.34
@@ -16,7 +16,7 @@
 
 |#
 
-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.33 2006/07/03 00:32:52 ktilton Exp $
+;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.34 2006/07/06 22:10:39 ktilton Exp $
 
 (defpackage :celtk
   (:nicknames "CTK")
@@ -68,7 +68,7 @@
 
 ; --- tk-format --- talking to wish/Tk -----------------------------------------------------
 
-(defconstant +tk-client-task-priority+
+(defparameter +tk-client-task-priority+
     '(:delete :forget :destroy 
        :pre-make-tk :make-tk :make-tk-menubutton :post-make-tk 
        :variable :bind :selection :trace :configure :grid :pack :fini))
@@ -249,4 +249,4 @@
           else do (push ch item)
           finally (gather-item)
             (return (nreverse items))))))
-        
\ No newline at end of file
+        
--- /project/cells/cvsroot/Celtk/composites.lisp	2006/07/03 00:32:52	1.12
+++ /project/cells/cvsroot/Celtk/composites.lisp	2006/07/06 22:10:40	1.13
@@ -69,7 +69,7 @@
 (defmodel composite-widget (widget)
   ((kids-packing :initarg :kids-packing :accessor kids-packing :initform nil)))
 
-(eval-when (compile load eval)
+(eval-now!
   (export '(title$ active .time)))
 
 (defvar *app*)
--- /project/cells/cvsroot/Celtk/font.lisp	2006/06/07 22:13:41	1.5
+++ /project/cells/cvsroot/Celtk/font.lisp	2006/07/06 22:10:40	1.6
@@ -20,7 +20,7 @@
 
 ;;; --- fonts obtained from Tk-land ---------------
 
-(eval-when (compile load eval)
+(eval-now!
   (export '(make-tkfinfo tkfinfo-family tkfinfo-size tkfinfo-slant tkfinfo-ascent  tkfinfo-linespace tkfinfo-fixed
              tkfont-id tkfont-info tkfinfo-ascent tkfont-height tkfont-ascent 
              tkfinfo-descent ^tkfont-descent ^tkfont-find
@@ -31,7 +31,7 @@
   `(progn ,@(loop for fn-name in fn-names
                   collecting (let ((^name (format nil "^~:@(~a~)" fn-name)))
                                `(progn
-                                  (eval-when (compile load eval)
+                                  (eval-now!
                                     (export '(,(intern ^name))))
                                   (defmacro ,(intern ^name) ()
                                     `(,',fn-name self)))))))
--- /project/cells/cvsroot/Celtk/run.lisp	2006/07/03 00:32:52	1.18
+++ /project/cells/cvsroot/Celtk/run.lisp	2006/07/06 22:10:40	1.19
@@ -20,7 +20,7 @@
 
 ;;; --- running a Celtk (window class, actually) --------------------------------------
 
-(eval-when (compile load eval)
+(eval-now!
   (export '(tk-scaling run-window test-window)))
 
 (defun run-window (root-class &optional (resetp t) &rest window-initargs)
@@ -149,12 +149,9 @@
   "nails existing window as a convenience in iterative development"
   (declare (ignorable root-class))
 
-  #+tki (when (and *tkw* (open-stream-p *tkw*))
-    (format *tkw* "wm withdraw .~%")
-    (force-output *tkw*)
-    (format *tkw* "destroy .%")
-    (force-output *tkw*)
-    (setf *tkw* nil))
+  #+notquite (when (and *tkw* (fm-parent *tkw*)) ;; probably a better way to test if the window is still alive
+    (not-to-be (fm-parent *tkw*))
+    (setf *tkw* nil ctk::*app* nil))
 
   (apply 'run-window root-class resetp window-initargs))
 
--- /project/cells/cvsroot/Celtk/timer.lisp	2006/05/25 07:12:59	1.8
+++ /project/cells/cvsroot/Celtk/timer.lisp	2006/07/06 22:10:40	1.9
@@ -44,7 +44,7 @@
 ;;; Timer is totally a work-in-progress with much development ahead.
 ;;;
 
-(eval-when (compile load eval)
+(eval-now!
   (export '(repeat ^repeat)))
 
 (defmodel timer ()
--- /project/cells/cvsroot/Celtk/tk-object.lisp	2006/06/29 09:54:52	1.7
+++ /project/cells/cvsroot/Celtk/tk-object.lisp	2006/07/06 22:10:40	1.8
@@ -59,7 +59,7 @@
             collecting `(setf (get ',slot-name 'tk-config-option) ',tk-option)
             into outputs
             finally (return (values slot-defs outputs)))
-      `(eval-when (compile load eval)
+      `(eval-now!
          (defmodel ,class ,(or superclasses '(tk-object))
            (,@(append std-slots slots))
            ,@(remove-if (lambda (k) (find k '(:default-initargs :tk-spec))) defclass-options :key 'car)
@@ -84,7 +84,7 @@
       collecting (list slot-name (if (atom tk-option-def)
                                      tk-option-def (cadr tk-option-def)))))
 
-(eval-when (compile load eval)
+(eval-now!
   (defun de- (sym)
     (remove #\- (symbol-name sym) :end 1)))
   
--- /project/cells/cvsroot/Celtk/togl.lisp	2006/07/03 01:31:38	1.13
+++ /project/cells/cvsroot/Celtk/togl.lisp	2006/07/06 22:10:40	1.14
@@ -71,7 +71,7 @@
 ;; Togl_FreeColorOverlay
 ;; Togl_DumpToEpsFile
 
-(eval-when (compile load eval)
+(eval-now!
   (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)))
@@ -179,9 +179,11 @@
        (defmethod ,(intern uc$) ((self togl))))))
 
 (def-togl-callback create ()
-  (trc "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr self)
-  (setf (togl-ptr self) (setf cl-ftgl::*ftgl-ogl* ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready
-                          togl-ptr))
+  (trc nil "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr self)
+;;;  (setf (togl-ptr self) (setf cl-ftgl::*ftgl-ogl* ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready
+;;;                          togl-ptr))
+
+  (setf (togl-ptr self) togl-ptr)
   (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))
 
 (def-togl-callback display ())
--- /project/cells/cvsroot/Celtk/widget.lisp	2006/06/29 09:54:52	1.15
+++ /project/cells/cvsroot/Celtk/widget.lisp	2006/07/06 22:10:40	1.16
@@ -71,7 +71,7 @@
     :event-handler nil #+debug (lambda (self xe)
                                  (TRC "debug event handler" self (tk-event-type (xsv type xe))))))
 
-(eval-when (compile load eval)
+(eval-now!
   (export '()))
 
 (defun tk-create-event-handler-ex (widget callback-name &rest masks)
@@ -153,7 +153,7 @@
 
 ;;; --- items -----------------------------------------------------------------------
 
-(eval-when (compile load eval)
+(eval-now!
   (export '(canvas-offset ^canvas-offset coords-tweak ^coords-tweak caret-tweak ^caret-tweak
              decorations ^decorations)))
 



From ktilton at common-lisp.net  Sat Jul  8 03:28:07 2006
From: ktilton at common-lisp.net (ktilton)
Date: Fri,  7 Jul 2006 23:28:07 -0400 (EDT)
Subject: [cells-cvs] CVS cells/utils-kt
Message-ID: <20060708032807.B6B3879000@common-lisp.net>

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

Modified Files:
	detritus.lisp 
Log Message:


--- /project/cells/cvsroot/cells/utils-kt/detritus.lisp	2006/07/06 22:10:03	1.7
+++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp	2006/07/08 03:28:07	1.8
@@ -20,7 +20,7 @@
 (in-package :utils-kt)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (export '(eval-now!)))
+  (export '(eval-now! export!)))
 
 (defmacro wdbg (&body body)
   `(let ((*dbg* t))



From ktilton at common-lisp.net  Mon Jul 24 05:03:08 2006
From: ktilton at common-lisp.net (ktilton)
Date: Mon, 24 Jul 2006 01:03:08 -0400 (EDT)
Subject: [cells-cvs] CVS cells/utils-kt
Message-ID: <20060724050308.D4F001C00F@common-lisp.net>

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

Modified Files:
	utils-kt.lpr 
Log Message:
Looks like copying files back and forth has fooled CVS into thinking everything changed. <sigh>

--- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr	2006/06/29 09:54:06	1.13
+++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr	2006/07/24 05:03:08	1.14
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jul 12, 2006 12:22)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 



From ktilton at common-lisp.net  Mon Jul 24 05:03:08 2006
From: ktilton at common-lisp.net (ktilton)
Date: Mon, 24 Jul 2006 01:03:08 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060724050308.A97CB1C017@common-lisp.net>

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

Modified Files:
	cell-types.lisp cells.lpr integrity.lisp link.lisp 
	md-slot-value.lisp propagate.lisp synapse.lisp 
Log Message:
Looks like copying files back and forth has fooled CVS into thinking everything changed. <sigh>

--- /project/cells/cvsroot/cells/cell-types.lisp	2006/06/29 09:54:06	1.15
+++ /project/cells/cvsroot/cells/cell-types.lisp	2006/07/24 05:03:07	1.16
@@ -45,9 +45,9 @@
 (defun caller-drop (used caller)
   (fifo-delete (c-caller-store used) caller))
 
-(defmethod trcp ((c cell))
-  nil #+(or) (and (typep (c-model c) 'index)
-              (eql 'state (c-slot-name c))))
+;;;(defmethod trcp ((c cell))
+;;;  (and ;; (typep (c-model c) 'index)
+;;;   (find (c-slot-name c) '(celtk::state mathx::problem))))
 
 ; --- ephemerality --------------------------------------------------
 ; 
@@ -131,20 +131,23 @@
 ;_____________________ print __________________________________
 
 (defmethod print-object :before ((c cell) stream)
- (declare (ignorable c))
-  (format stream "[~a~a:" (if (c-inputp c) "i" "?")
-    (cond
-     ((null (c-model c)) #\0)
-     ((eq :eternal-rest (md-state (c-model c))) #\_)
-     ((not (c-currentp c)) #\#)
-     (t #\space))))
+  (unless *print-readably*
+    (format stream "[~a~a:" (if (c-inputp c) "i" "?")
+      (cond
+       ((null (c-model c)) #\0)
+       ((eq :eternal-rest (md-state (c-model c))) #\_)
+       ((not (c-currentp c)) #\#)
+       (t #\space)))))
 
 (defmethod print-object ((c cell) stream)
-  (c-print-value c stream)
-  (format stream "=~d/~a/~a]"
-    (c-pulse c)
-    (symbol-name (or (c-slot-name c) :anoncell))
-    (or (c-model c) :anonmd)))
+  (if *print-readably*
+      (call-next-method)
+    (progn
+      (c-print-value c stream)
+      (format stream "=~d/~a/~a]"
+        (c-pulse c)
+        (symbol-name (or (c-slot-name c) :anoncell))
+        (or (c-model c) :anonmd)))))
 
 ;__________________
 
--- /project/cells/cvsroot/cells/cells.lpr	2006/06/29 09:54:06	1.17
+++ /project/cells/cvsroot/cells/cells.lpr	2006/07/24 05:03:08	1.18
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jul 19, 2006 19:38)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 
--- /project/cells/cvsroot/cells/integrity.lisp	2006/07/06 22:10:01	1.11
+++ /project/cells/cvsroot/cells/integrity.lisp	2006/07/24 05:03:08	1.12
@@ -53,18 +53,21 @@
           (funcall action)
         (finish-business)))))
 
-(defmacro without-integrity ((&optional dbg-info) &rest body)
+(export! with-integrity-bubble)
+
+(defmacro with-integrity-bubble ((&optional dbg-info) &rest body)
   "Whimsical name for launching a self-contained, dynamic integrity chunk, as with
 string-to-mx in the math-paper project, where everything is fully isolated from the
 outside computation."
-  `(call-without-integrity ,dbg-info (lambda () , at body)))
+  `(call-with-integrity-bubble ,dbg-info (lambda () , at body)))
 
-(defun call-without-integrity (dbg-info action)
+(defun call-with-integrity-bubble (dbg-info action)
   (declare (ignorable dbg-info))
   (let ((*within-integrity* nil)
           *unfinished-business*
           *defer-changes*
-        *call-stack*)
+        *call-stack*
+        (*data-pulse-id* 0))
     (funcall action)))
 
 (defun ufb-queue (opcode)
--- /project/cells/cvsroot/cells/link.lisp	2006/07/06 22:10:01	1.15
+++ /project/cells/cvsroot/cells/link.lisp	2006/07/24 05:03:08	1.16
@@ -95,7 +95,7 @@
                      
 (defmethod c-unlink-from-used ((caller c-dependent))
   (dolist (used (cd-useds caller))
-    #+dfdbg (trc caller "unlinking from used" caller used)
+    #+dfdbg (trc nil "unlinking from used" caller used)
     (c-unlink-caller used caller))
   ;; shouldn't be necessary (setf (cd-useds caller) nil)
   )
--- /project/cells/cvsroot/cells/md-slot-value.lisp	2006/06/29 09:54:06	1.24
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2006/07/24 05:03:08	1.25
@@ -42,14 +42,15 @@
   (if c
       (prog1
           (with-integrity ()
-            (ensure-value-is-current c))
+            (ensure-value-is-current c :mdsv nil))
         (when (car *call-stack*)
           (record-caller c)))
     (values (bd-slot-value self slot-name) nil)))
   
-(defun ensure-value-is-current (c)
+(defun ensure-value-is-current (c debug-id caller)
+  (declare (ignorable debug-id caller))
   (count-it :ensure-value-is-current)
-  (trc nil "ensure-value-is-current >" c)
+  (trc nil "ensure-value-is-current > entry" c :now-pulse *data-pulse-id* debug-id caller)
   (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) (ephemeral-reset c))). ie, do not assume inputs are never obsolete
@@ -58,16 +59,17 @@
 
    ((or (not (c-validp c))
       (some (lambda (used)
-              (ensure-value-is-current used)
-              (trc nil "comparing pulses (caller, used): " (c-pulse c)(c-pulse used))
+              (ensure-value-is-current used :nested c)
+              (trc nil "comparing pulses (caller, used, used-changed): "  c used (c-changed used))
               (when (and (c-changed used) (> (c-pulse used)(c-pulse c)))
-                 (trc nil "used changed" c used)
+                 (trc nil "used changed and newer !!!!!!" c used)
                 t))
         (cd-useds c)))
-    (trc nil "ensuring current calc-set of" (c-slot-name c) debug-id)
+    (trc nil "ensuring current calc-set of" (c-slot-name c))
     (calculate-and-set c))
 
-   (t (c-pulse-update c :valid-uninfluenced)))
+   (t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) )
+     (c-pulse-update c :valid-uninfluenced)))
 
   (when (c-unboundp c)
     (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c)))
@@ -143,6 +145,7 @@
           ;
           ; --- data flow propagation -----------
           ;
+          
           (setf (c-changed c) t)
           (without-c-dependency
               (c-propagate c prior-value t)))))))
@@ -207,6 +210,7 @@
         
         ; --- data flow propagation -----------
         (unless (eq propagation-code :no-propagate)
+          (trc nil "md-slot-value-assume flagging as changed" c)
           (setf (c-changed c) t)
           (c-propagate c prior-value (eq prior-state :valid)))  ;; until 06-02-13 was (not (eq prior-state :unbound))
         
--- /project/cells/cvsroot/cells/propagate.lisp	2006/06/23 01:04:56	1.18
+++ /project/cells/cvsroot/cells/propagate.lisp	2006/07/24 05:03:08	1.19
@@ -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 as unchanged!!!" *data-pulse-id* c key)
   (setf (c-changed c) nil
       (c-pulse c) *data-pulse-id*))
 
@@ -165,11 +165,11 @@
       (with-integrity (:tell-dependents c)
         (assert (null *call-stack*))
         (let ((*causation* causation))
-          (trc nil "c-propagate-to-callers > notifying callers of" c (mapcar 'c-slot-name (c-callers c)))
+          (trc nil "c-propagate-to-callers > actually 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))))))))
+              (trc nil "propagating to caller is caller:" caller)
+              (ensure-value-is-current caller :prop-from c))))))))
 
 
 
--- /project/cells/cvsroot/cells/synapse.lisp	2006/07/06 22:10:01	1.13
+++ /project/cells/cvsroot/cells/synapse.lisp	2006/07/24 05:03:08	1.14
@@ -39,7 +39,7 @@
        (prog1
            (multiple-value-bind (v p)
                (with-integrity ()
-                 (ensure-value-is-current synapse))
+                 (ensure-value-is-current synapse :synapse (car *call-stack*)))
              (trc nil "with-synapse: synapse, v, prop" synapse v p)
              (values v p))
          (record-caller synapse)))))



From ktilton at common-lisp.net  Mon Jul 24 05:04:01 2006
From: ktilton at common-lisp.net (ktilton)
Date: Mon, 24 Jul 2006 01:04:01 -0400 (EDT)
Subject: [cells-cvs] CVS Celtk
Message-ID: <20060724050401.382261C010@common-lisp.net>

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

Modified Files:
	CELTK.lpr timer.lisp togl.lisp 
Log Message:
Not really changed for the most part.

--- /project/cells/cvsroot/Celtk/CELTK.lpr	2006/06/29 09:54:52	1.17
+++ /project/cells/cvsroot/Celtk/CELTK.lpr	2006/07/24 05:04:01	1.18
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jul 19, 2006 19:38)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 
--- /project/cells/cvsroot/Celtk/timer.lisp	2006/07/06 22:10:40	1.9
+++ /project/cells/cvsroot/Celtk/timer.lisp	2006/07/24 05:04:01	1.10
@@ -79,8 +79,8 @@
                      (funcall (^action) self)
                      (setf (^executed) t))))
    (after-factory :reader after-factory
-     :initform (c? (bwhen (rpt (eko (nil ">>> repeat") (when (eq (^state) :on)
-                               (^repeat))))
+     :initform (c? (bwhen (rpt (when (eq (^state) :on)
+                               (^repeat)))
                    (when (or (zerop (^executions)) (^executed)) ;; dispatch initially or after an execution
                      (when (zerop (^executions))
                        (setf (elapsed self) (now)))
@@ -90,19 +90,23 @@
                        (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters
                          (set-timer self (^delay))))))))))
 
+(defobserver state ((self timer))
+  (unless (eq new-value :on)
+    (trc "bingo!!!!!!!!!!!!!!!!!!!!! state takes out timer" self)
+    (cancel-timer self)))
+
 (defun set-timer (self time)
   (let ((callback-id (symbol-name (gentemp "AFTER"))))
     (setf (gethash callback-id (dictionary *tkw*)) self)
     (setf (cancel-id self) (tk-eval "after ~a {do-on-command ~a}" time callback-id))))
 
 (defun cancel-timer (timer)
-  (setf (state timer) :off)
   (when (cancel-id timer)
-      (tk-format-now "after cancel ~a" (cancel-id timer)))) ;; Tk doc says OK if cancelling already executed
+    (tk-format-now "after cancel ~a" (cancel-id timer)))) ;; Tk doc says OK if cancelling already executed
 
 (defobserver timers ((self tk-object) new-value old-value)
   (dolist (k (set-difference old-value new-value))
-    (cancel-timer k)))
+    (setf (state k) :off))) ;; actually could be anything but :on
 
 
     
\ No newline at end of file
--- /project/cells/cvsroot/Celtk/togl.lisp	2006/07/06 22:10:40	1.14
+++ /project/cells/cvsroot/Celtk/togl.lisp	2006/07/24 05:04:01	1.15
@@ -167,11 +167,14 @@
          (callback :pointer))
        (defcallback ,(intern cb$) :void ((,ptr-var :pointer))
          (unless (c-stopped)
-           (let ((,self-var (or (gethash (pointer-address ,ptr-var) (tkwins *tkw*))
-                              (gethash (togl-ident ,ptr-var)(dictionary *tkw*)))))
-             , at preamble
-             (trc nil "selves" ,cb$ (togl-ident ,ptr-var) (gethash (pointer-address ,ptr-var) (tkwins *tkw*))(gethash (togl-ident ,ptr-var)(dictionary *tkw*)))
-             (,(intern uc$) ,self-var))))
+           (bif (,self-var (or (gethash (pointer-address ,ptr-var) (tkwins *tkw*))
+                             (gethash (togl-ident ,ptr-var)(dictionary *tkw*))))
+             (progn
+               , at preamble
+               (trc nil "selves" ,cb$ (togl-ident ,ptr-var) (gethash (pointer-address ,ptr-var) (tkwins *tkw*))(gethash (togl-ident ,ptr-var)(dictionary *tkw*)))
+               (,(intern uc$) ,self-var))
+             (trc "WARNING: Togl callback ~a sees unknown togl pointer ~a :address ~a :ident ~a"
+               ,cb$ ,ptr-var (pointer-address ,ptr-var) (togl-ident ,ptr-var)))))
        (defmethod ,(intern uc$) :around ((self togl))
          (if (,(intern cb-slot$) self)
                (funcall (,(intern cb-slot$) self) self)



From ktilton at common-lisp.net  Tue Jul 25 10:51:48 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue, 25 Jul 2006 06:51:48 -0400 (EDT)
Subject: [cells-cvs] CVS cells
Message-ID: <20060725105148.8BE3336027@common-lisp.net>

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

Modified Files:
	cell-types.lisp cells.lisp cells.lpr md-slot-value.lisp 
Log Message:


--- /project/cells/cvsroot/cells/cell-types.lisp	2006/07/24 05:03:07	1.16
+++ /project/cells/cvsroot/cells/cell-types.lisp	2006/07/25 10:51:48	1.17
@@ -45,9 +45,10 @@
 (defun caller-drop (used caller)
   (fifo-delete (c-caller-store used) caller))
 
-;;;(defmethod trcp ((c cell))
-;;;  (and ;; (typep (c-model c) 'index)
-;;;   (find (c-slot-name c) '(celtk::state mathx::problem))))
+(defmethod trcp ((c cell))
+  #+not (and ;; (typep (c-model c) 'index)
+   (find (c-slot-name c) '(celtk::state mathx::problem))))
+
 
 ; --- ephemerality --------------------------------------------------
 ; 
@@ -131,7 +132,7 @@
 ;_____________________ print __________________________________
 
 (defmethod print-object :before ((c cell) stream)
-  (unless *print-readably*
+  (unless (or *stop* *print-readably*)
     (format stream "[~a~a:" (if (c-inputp c) "i" "?")
       (cond
        ((null (c-model c)) #\0)
@@ -139,8 +140,9 @@
        ((not (c-currentp c)) #\#)
        (t #\space)))))
 
+
 (defmethod print-object ((c cell) stream)
-  (if *print-readably*
+  (if (or *stop* *print-readably*)
       (call-next-method)
     (progn
       (c-print-value c stream)
@@ -149,6 +151,7 @@
         (symbol-name (or (c-slot-name c) :anoncell))
         (or (c-model c) :anonmd)))))
 
+
 ;__________________
 
 (defmethod c-print-value ((c c-ruled) stream)
--- /project/cells/cvsroot/cells/cells.lisp	2006/06/25 21:30:34	1.14
+++ /project/cells/cvsroot/cells/cells.lisp	2006/07/25 10:51:48	1.15
@@ -45,8 +45,8 @@
   (trc nil "------ cell reset ----------------------------"))
 
 (defun c-stop (&optional why)
-  (format t "~&C-STOP> stopping because ~a" why)
-  (setf *stop* t))
+  (setf *stop* t)
+  (format t "~&C-STOP> stopping because ~a" why)  )
 
 (define-symbol-macro .stop
     (c-stop :user))
@@ -132,9 +132,12 @@
 
 (defun c-break (&rest args)
   (unless *stop*
-    (c-stop args)
-    (format t "c-break > stopping > ~a" args)
-    (apply 'break args)))
+    (LET ((*print-level* 3)
+          (*print-circle* t)
+          )
+      (c-stop args)
+      (format t "c-break > stopping > ~a" args)
+      (apply 'break args))))
 
 
 
--- /project/cells/cvsroot/cells/cells.lpr	2006/07/24 05:03:08	1.18
+++ /project/cells/cvsroot/cells/cells.lpr	2006/07/25 10:51:48	1.19
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jul 19, 2006 19:38)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jul 24, 2006 15:27)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 
--- /project/cells/cvsroot/cells/md-slot-value.lisp	2006/07/24 05:03:08	1.25
+++ /project/cells/cvsroot/cells/md-slot-value.lisp	2006/07/25 10:51:48	1.26
@@ -18,7 +18,7 @@
 
 (in-package :cells)
 
-(defparameter *ide-app-hard-to-kill* nil)
+(defparameter *ide-app-hard-to-kill* t)
 
 (defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name)))
   (tagbody
@@ -83,15 +83,18 @@
              (return-from calculate-and-set))
            
            (when (find c *call-stack*) ;; circularity
-             (trc "cell appears in call stack:" c)
-             (loop with caller-reiterated
+             (trc "cell appears in call stack:" *stop*)
+             (setf *stop* t)
+             (break)
+             #+not (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 (see above)" c))
+              "cell ~a midst askers (see above)" c)
+             (break))
   
            (multiple-value-bind (raw-value propagation-code)
                (calculate-and-link c)



From ktilton at common-lisp.net  Tue Jul 25 10:51:48 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue, 25 Jul 2006 06:51:48 -0400 (EDT)
Subject: [cells-cvs] CVS cells/gui-geometry
Message-ID: <20060725105148.9AFC636028@common-lisp.net>

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

Modified Files:
	geometer.lisp 
Log Message:


--- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp	2006/07/06 22:10:02	1.6
+++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp	2006/07/25 10:51:48	1.7
@@ -44,7 +44,7 @@
                    (mk-kid-slot (px :if-missing t)
                      (c? (px-maintain-pl 0)))
                    (mk-kid-slot (py :if-missing t)
-                     (c? (break)(py-maintain-pt 0))))))
+                     (c? (py-maintain-pt 0))))))
 
 (defmodel geo-kid-sized (family) 
     ()



From ktilton at common-lisp.net  Tue Jul 25 10:51:49 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue, 25 Jul 2006 06:51:49 -0400 (EDT)
Subject: [cells-cvs] CVS cells/utils-kt
Message-ID: <20060725105149.07AF738004@common-lisp.net>

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

Modified Files:
	debug.lisp utils-kt.lpr 
Log Message:


--- /project/cells/cvsroot/cells/utils-kt/debug.lisp	2006/05/20 06:32:20	1.8
+++ /project/cells/cvsroot/cells/utils-kt/debug.lisp	2006/07/25 10:51:48	1.9
@@ -96,6 +96,8 @@
   (format t "decrementing trc depth ~d" *trcdepth*)
   (decf *trcdepth*))
   
+(export! wtrc)
+
 (defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body )
   `(let ((*trcdepth* (if *trcdepth*
                          (1+ *trcdepth*)
--- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr	2006/07/24 05:03:08	1.14
+++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr	2006/07/25 10:51:48	1.15
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jul 12, 2006 12:22)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jul 24, 2006 15:27)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 



From ktilton at common-lisp.net  Tue Jul 25 10:53:41 2006
From: ktilton at common-lisp.net (ktilton)
Date: Tue, 25 Jul 2006 06:53:41 -0400 (EDT)
Subject: [cells-cvs] CVS Celtk
Message-ID: <20060725105341.34A8049036@common-lisp.net>

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

Modified Files:
	togl.lisp 
Log Message:


--- /project/cells/cvsroot/Celtk/togl.lisp	2006/07/24 05:04:01	1.15
+++ /project/cells/cvsroot/Celtk/togl.lisp	2006/07/25 10:53:41	1.16
@@ -183,8 +183,8 @@
 
 (def-togl-callback create ()
   (trc nil "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr self)
-;;;  (setf (togl-ptr self) (setf cl-ftgl::*ftgl-ogl* ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready
-;;;                          togl-ptr))
+  (setf (togl-ptr self) (setf cl-ftgl::*ftgl-ogl* ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready
+                          togl-ptr))
 
   (setf (togl-ptr self) togl-ptr)
   (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))