From ktilton at common-lisp.net Fri Nov 3 13:37:12 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 3 Nov 2006 08:37:12 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20061103133712.30B5039032@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv31675 Modified Files: cell-types.lisp constructors.lisp family.lisp fm-utilities.lisp link.lisp md-slot-value.lisp md-utilities.lisp propagate.lisp Log Message: a couple of serious bug fixes, actually. --- /project/cells/cvsroot/cells/cell-types.lisp 2006/10/28 18:20:48 1.21 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/11/03 13:37:10 1.22 @@ -42,6 +42,28 @@ debug md-info) +;_____________________ print __________________________________ + +(defmethod print-object :before ((c cell) stream) + (unless (or *stop* *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) + (if (or *stop* *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 (and (c-model c)(md-name (c-model c))) :anonmd))))) + (defmethod trcp :around ((c cell)) (or (c-debug c) (call-next-method))) @@ -136,28 +158,6 @@ (defun c-unboundp (c) (eql :unbound (c-value-state c))) -;_____________________ print __________________________________ - -(defmethod print-object :before ((c cell) stream) - (unless (or *stop* *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) - (if (or *stop* *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/constructors.lisp 2006/10/28 18:20:48 1.11 +++ /project/cells/cvsroot/cells/constructors.lisp 2006/11/03 13:37:10 1.12 @@ -53,13 +53,14 @@ :value-state :unevaluated :rule (c-lambda (without-c-dependency , at body)))) -(defmacro c?n-until (&body body) +(defmacro c?n-until (args &body body) `(make-c-dependent :optimize :when-value-t :code ',body :inputp t :value-state :unevaluated - :rule (c-lambda , at body))) + :rule (c-lambda , at body) + , at args)) (export! c?once c?n-until) (defmacro c?once (&body body) --- /project/cells/cvsroot/cells/family.lisp 2006/09/05 18:40:47 1.14 +++ /project/cells/cvsroot/cells/family.lisp 2006/11/03 13:37:10 1.15 @@ -36,8 +36,8 @@ new-value) (defmethod print-object ((self model) s) - (format s "~a" (type-of self)) - #+shhh (format s "~a" (or (md-name self) (type-of self)))) + #+shhh (format s "~a" (type-of self)) + (format s "~a" (or (md-name self) (type-of self)))) (define-symbol-macro .parent (fm-parent self)) --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/10/13 05:56:38 1.12 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/11/03 13:37:10 1.13 @@ -295,12 +295,11 @@ (car (cdr (member ,s (kids (fm-parent ,s)))))))) (defun find-prior (self sibs &key (test #'true-that)) - (c-assert (member self sibs)) ;; got this by accidentally having toolbar kids dependent..on second calc, - ;; all newkids got over, and when old kids tried to recalculate...not in sibs!! + (c-assert (member self sibs) () "find-prior of ~a does not find it in sibs arg ~a" self sibs) (unless (eql self (car sibs)) (labels ((fpsib (rsibs &aux (psib (car rsibs))) - (c-assert rsibs () "~&find-prior > fpsib > self ~s not found to prior off" self) + (c-assert rsibs () "find-prior > fpsib > self ~s not found to prior off" self) (if (eql self (cadr rsibs)) (when (funcall test psib) psib) (or (fpsib (cdr rsibs)) --- /project/cells/cvsroot/cells/link.lisp 2006/10/28 18:20:48 1.20 +++ /project/cells/cvsroot/cells/link.lisp 2006/11/03 13:37:10 1.21 @@ -39,7 +39,7 @@ finally (return (values (when u-pos (- length u-pos)) length))) (when (null used-pos) - (trc caller "c-link > new caller,used " caller used) + (trc nil "c-link > new caller,used " caller used) (count-it :new-used) (setf used-pos useds-len) (push used (cd-useds caller)) @@ -62,7 +62,7 @@ (usage-size (array-dimension (cd-usage c) 0)) (dbg nil)) ;; #+not (and (typep (c-model c) 'mathx::mx-solver-stack) ;;(eq (c-slot-name c) '.kids)))) - (declare (ignorable usage-size)) + (declare (ignorable dbg usage-size)) (when (cd-useds c) (let (rev-pos) (labels ((nail-unused (useds) @@ -71,7 +71,7 @@ (zerop (sbit usage rpos))) (progn (count-it :unlink-unused) - (trc c "c-unlink-unused" c :dropping-used (car useds)) + (trc nil "c-unlink-unused" c :dropping-used (car useds)) (c-unlink-caller (car useds) c) (rplaca useds nil)) (progn @@ -83,7 +83,7 @@ (nail-unused (cdr useds)) (handle-used (incf rev-pos))) (handle-used (setf rev-pos 0)))))) - (trc dbg "cd-useds length" (length (cd-useds c)) c) + (trc nil "cd-useds length" (length (cd-useds c)) c) (nail-unused (cd-useds c)) (setf (cd-useds c) (delete nil (cd-useds c))))))) @@ -104,7 +104,7 @@ (defmethod c-unlink-from-used ((caller c-dependent)) (dolist (used (cd-useds caller)) - #+dfdbg (trc nil "unlinking from used" caller used) + (trc nil "unlinking from used" caller used) (c-unlink-caller used caller)) ;; shouldn't be necessary (setf (cd-useds caller) nil) ) @@ -115,7 +115,7 @@ ;---------------------------------------------------------- (defun c-unlink-caller (used caller) - (trc nil "caller unlinking from used" caller used) + (trc caller "(1) caller unlinking from (2) used" caller used) (caller-drop used caller) (c-unlink-used caller used)) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/10/28 18:20:48 1.30 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/11/03 13:37:10 1.31 @@ -66,7 +66,8 @@ ;; ((and (c-inputp c) (c-validp c) ;; a c?n (ruled-then-input) cell will not be valid at first - (not (and (eq (cd-optimize c) :when-value-t) + (not (and (typep c 'c-dependent) + (eq (cd-optimize c) :when-value-t) (null (c-value c)))))) ((or (not (c-validp c)) @@ -86,6 +87,7 @@ (when (> (c-pulse-last-changed used)(c-pulse c)) (trc nil "used changed and newer !!!!!!" c debug-id used) t)))))) + (assert (typep c 'c-dependent)) (check-reversed (cd-useds c)))) (trc nil "kicking off calc-set of" (c-slot-name c) :pulse *data-pulse-id*) (calculate-and-set c)) @@ -135,6 +137,7 @@ (defun calculate-and-link (c) (let ((*call-stack* (cons c *call-stack*)) (*defer-changes* t)) + (assert (typep c 'c-ruled)) (cd-usage-clear-all c) (multiple-value-prog1 (funcall (cr-rule c) c) @@ -246,9 +249,10 @@ ; --- data flow propagation ----------- (unless (eq propagation-code :no-propagate) - (trc nil "md-slot-value-assume flagging as changed" c) + (trc nil "md-slot-value-assume flagging as changed: prior state, value:" prior-state prior-value ) (setf (c-pulse-last-changed c) *data-pulse-id*) - (c-propagate c prior-value (eq prior-state :valid))) ;; until 06-02-13 was (not (eq prior-state :unbound)) + (c-propagate c prior-value (or (eq prior-state :valid) + (eq prior-state :uncurrent)))) ;; until 06-02-13 was (not (eq prior-state :unbound)) absorbed-value))) @@ -260,7 +264,7 @@ (null (cd-useds c)) (cd-optimize c) (not (c-optimized-away-p c)) ;; c-streams (FNYI) may come this way repeatedly even if optimized away - (c-validp c) ;; /// when would this not be the case? + (c-validp c) ;; /// when would this not be the case? and who cares? (not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around) (not (c-inputp c)) ;; yes, dependent cells can be inputp ) --- /project/cells/cvsroot/cells/md-utilities.lisp 2006/10/28 18:20:48 1.10 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2006/11/03 13:37:10 1.11 @@ -65,6 +65,7 @@ (c-unlink-from-used c) (dolist (caller (c-callers c)) (setf (c-value-state caller) :uncurrent) + (trc nil "c-quiesce unlinking caller" c) (c-unlink-caller c caller)) (setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho ))) --- /project/cells/cvsroot/cells/propagate.lisp 2006/10/17 21:28:39 1.24 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/11/03 13:37:10 1.25 @@ -61,7 +61,8 @@ (defun c-propagate (c prior-value prior-value-supplied) (count-it :c-propagate) - + (when prior-value + (assert prior-value-supplied () "How can prior-value-supplied be nil if prior-value is not?!! ~a" c)) (let (*call-stack* (*c-prop-depth* (1+ *c-prop-depth*)) (*defer-changes* t)) @@ -72,8 +73,8 @@ (when *stop* (princ #\.)(princ #\!) (return-from c-propagate)) - (trc c "c-propagate> !!!!!!!!!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)) c) - + (trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)) c) + (trc nil "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c) (when *c-debug* (when (> *c-prop-depth* 250) (trc nil "c-propagate deep" *c-prop-depth* (c-model c) (c-slot-name c) #+nah c)) @@ -82,6 +83,24 @@ ; --- manifest new value as needed --- ; + ; 20061030 Trying not-to-be first because doomed instances may be interested in callers + ; who will decide to propagate. If a family instance kids slot is changing, a doomed kid + ; will be out of the kids but not yet quiesced. If the propagation to this rule asks the kid + ; to look at its siblings (say a view instance being deleted from a stack who looks to the psib + ; pb to decide its own pt), the doomed kid will still have a parent but not be in its kids slot + ; when it goes looking for a sibling relative to its position. + ; + (when (and prior-value-supplied + prior-value + (md-slot-owning (type-of (c-model c)) (c-slot-name c))) + (trc nil "c-propagate> contemplating lost") + (flet ((listify (x) (if (listp x) x (list x)))) + (bIf (lost (set-difference (listify prior-value) (listify (c-value c)))) + (progn + (trc nil "prop nailing owned" c :lost lost :leaving (c-value c)) + (mapcar 'not-to-be lost)) + (trc nil "no owned lost!!!!!")))) + ; 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). @@ -96,13 +115,7 @@ (slot-value-observe (c-slot-name c) (c-model c) (c-value c) prior-value prior-value-supplied) - (when (and prior-value-supplied - prior-value - (md-slot-owning (type-of (c-model c)) (c-slot-name c))) - (flet ((listify (x) (if (listp x) x (list x)))) - (bwhen (lost (set-difference (listify prior-value) (listify (c-value c)))) - (trc nil "prop nailing owned" c (c-value c) prior-value lost) - (mapcar 'not-to-be lost)))) + ; ; with propagation done, ephemerals can be reset. we also do this in c-awaken, so ; let the fn decide if C really is ephemeral. Note that it might be possible to leave @@ -174,13 +187,19 @@ (c-callers c)) (let ((causation (cons c *causation*)) ;; in case deferred ) + (TRC c "c-propagate-to-callers > queueing notifying callers" (mapcar 'c-slot-name (c-callers c))) (with-integrity (:tell-dependents c) (assert (null *call-stack*)) (let ((*causation* causation)) - (trc nil "c-propagate-to-callers > actually notifying callers of" c (mapcar 'c-slot-name (c-callers c))) + (trc c "c-propagate-to-callers > actually notifying callers of" c (mapcar 'c-slot-name (c-callers c))) (dolist (caller (c-callers c)) - (unless (member (c-lazy caller) '(t :always :once-asked)) - (trc nil "propagating to caller is caller:" caller) + (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller)) + + (dolist (caller (c-callers c)) ;; following code may modify c-callers list... + (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced + (member (c-lazy caller) '(t :always :once-asked))) + (assert (find c (cd-useds caller))) + (trc caller "propagating to caller is caller:" caller) (ensure-value-is-current caller :prop-from c)))))))) From ktilton at common-lisp.net Fri Nov 3 13:37:12 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 3 Nov 2006 08:37:12 -0500 (EST) Subject: [cells-cvs] CVS cells/gui-geometry Message-ID: <20061103133712.869627D002@common-lisp.net> Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv31675/gui-geometry Modified Files: geo-family.lisp Log Message: a couple of serious bug fixes, actually. --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/10/28 18:20:54 1.9 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/11/03 13:37:12 1.10 @@ -16,8 +16,8 @@ (in-package :gui-geometry) -(eval-now! - (export '(geo-inline-lazy))) +(export! geo-inline-lazy ^px-self-centered justify py-maintain-pt + ^prior-sib-pb spacing lr-maintain-pr) ;--------------- geo-inline ----------------------------- ; From ktilton at common-lisp.net Fri Nov 3 13:37:50 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 3 Nov 2006 08:37:50 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20061103133750.E145283043@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv31871 Modified Files: button.lisp demos.lisp entry.lisp label.lisp lotsa-widgets.lisp menu.lisp multichoice.lisp text-item.lisp Log Message: --- /project/cells/cvsroot/Celtk/button.lisp 2006/06/29 09:54:52 1.5 +++ /project/cells/cvsroot/Celtk/button.lisp 2006/11/03 13:37:50 1.6 @@ -27,7 +27,7 @@ -background -bitmap -borderwidth -cursor -disabledforeground (tkfont -font) -foreground -highlightbackground -highlightcolor -highlightthickness -image - -justify + (tk-justify -justify) -padx -pady -relief -repeatdelay -repeatinterval -takefocus -text -textvariable -underline -wraplength @@ -53,7 +53,7 @@ -background -bitmap -borderwidth -compound -cursor -disabledforeground (tkfont -font) -foreground -highlightbackground -highlightcolor -highlightthickness -image - -justify -padx -pady -relief -takefocus -text -textvariable + (tk-justify -justify) -padx -pady -relief -takefocus -text -textvariable -underline -wraplength -command -height -indicatoron -offrelief -overrelief -selectcolor -selectimage -state -tristateimage --- /project/cells/cvsroot/Celtk/demos.lisp 2006/09/05 18:43:22 1.24 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/11/03 13:37:50 1.25 @@ -172,7 +172,7 @@ :entry-values (c? (subseq (tk-eval-list "font families") 4 10))) (mk-label :text "Four score and seven years ago today, our fathers broguht forth on this continent a new nation..." :wraplength 200 - :justify 'left + :tk-justify 'left :tkfont (c? (list (selection (fm^ :font-face)) 14)))))))) --- /project/cells/cvsroot/Celtk/entry.lisp 2006/09/03 13:39:56 1.15 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/11/03 13:37:50 1.16 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.15 2006/09/03 13:39:56 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.16 2006/11/03 13:37:50 ktilton Exp $ (in-package :Celtk) @@ -29,7 +29,7 @@ -disabledforeground -disabledbackground -exportselection (tkfont -font) -foreground -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime -insertontime - -insertwidth -justify + -insertwidth (tk-justify -justify) -relief -selectbackground -selectborderwidth -selectforeground -takefocus -textvariable -xscrollcommand --- /project/cells/cvsroot/Celtk/label.lisp 2006/05/24 20:38:54 1.3 +++ /project/cells/cvsroot/Celtk/label.lisp 2006/11/03 13:37:50 1.4 @@ -25,7 +25,7 @@ -background -bitmap -borderwidth -compound -cursor -disabledforeground (tkfont -font) -foreground -highlightbackground -highlightcolor -highlightthickness -image - -justify + (tk-justify -justify) -padx -pady -relief -takefocus -text -textvariable -underline -height -state -width -wraplength) (:default-initargs @@ -40,7 +40,7 @@ -background -bitmap -borderwidth -compound -cursor -disabledforeground (tkfont -font) -foreground -highlightbackground -highlightcolor -highlightthickness -image - -justify + (tk-justify -justify) -padx -pady -relief -takefocus -text -textvariable -underline -wraplength -width -state -height) --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/07/03 01:31:38 1.5 +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/11/03 13:37:50 1.6 @@ -198,7 +198,7 @@ (mk-label :text "Four score and seven years ago today, our fathers broguht forth on this continent a new nation..." :wraplength 200 - :justify 'left + :tk-justify 'left :tkfont (c? (list (selection (fm^ :font-face)) (md-value (fm^ :font-size))))))) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/05/24 20:38:54 1.16 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/11/03 13:37:50 1.17 @@ -242,7 +242,7 @@ (:tk-spec menubutton -activebackground -activeforeground -anchor -background -bitmap -borderwidth -cursor -disabledforeground (tkfont -font) -foreground -highlightbackground -highlightcolor - -highlightthickness -image -justify -padx + -highlightthickness -image (tk-justify -justify) -padx -pady -relief -takefocus -text -textvariable -underline -wraplength -compound -direction -height -indicatoron --- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/06/07 22:13:41 1.10 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/11/03 13:37:50 1.11 @@ -98,7 +98,7 @@ -command -invalidcommand -increment -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime -insertontime - -insertwidth -jump -justify -orient + -insertwidth -jump (tk-justify -justify) -orient -padx -pady -relief -repeatdelay -repeatinterval -selectbackground -selectborderwidth -selectforeground -readonlybackground -state -to --- /project/cells/cvsroot/Celtk/text-item.lisp 2006/05/24 20:38:54 1.3 +++ /project/cells/cvsroot/Celtk/text-item.lisp 2006/11/03 13:37:50 1.4 @@ -33,7 +33,7 @@ ;; -- special --- -anchor (tkfont -font) - -justify + (tk-justify -justify) -text -underline -width) From ktilton at common-lisp.net Sat Nov 4 20:52:01 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 4 Nov 2006 15:52:01 -0500 (EST) Subject: [cells-cvs] CVS cells/cells-test Message-ID: <20061104205201.5F60F50001@common-lisp.net> Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv30831/cells-test Modified Files: test-family.lisp test.lisp Log Message: md-value -> value --- /project/cells/cvsroot/cells/cells-test/test-family.lisp 2006/03/16 05:22:08 1.3 +++ /project/cells/cvsroot/cells/cells-test/test-family.lisp 2006/11/04 20:52:01 1.4 @@ -129,26 +129,26 @@ (eko ("kidnos")(when (numberp mdv) (loop for kn from 1 to (floor mdv) collecting kn)))) - :md-value (c-in 5) - :kv-key #'md-value + :value (c-in 5) + :kv-key #'value :kid-factory (lambda (f kv) (incf kf-calls) (trc "making kid" kv) (make-instance 'bottle :fm-parent f - :md-value kv + :value kv :label (c? (format nil "bottle ~d out of ~d on the wall" - (^md-value) + (^value) (length (kids f))))))))) (ct-assert (eql 5 kf-calls)) (setq kf-calls 0) - (decf (md-value wall)) + (decf (value wall)) (ct-assert (eql 4 (length (kids wall)))) (ct-assert (zerop kf-calls)) (setq kf-calls 0) - (incf (md-value wall)) + (incf (value wall)) (ct-assert (eql 5 (length (kids wall)))) (ct-assert (eql 1 kf-calls)) --- /project/cells/cvsroot/cells/cells-test/test.lisp 2006/06/23 01:04:56 1.8 +++ /project/cells/cvsroot/cells/cells-test/test.lisp 2006/11/04 20:52:01 1.9 @@ -99,19 +99,19 @@ ;; test huge number of useds by one rule (defmd m-index (family) - :md-value (c? (bwhen (ks (^kids)) - ;(trc "chya" (mapcar 'md-value ks)) - (apply '+ (mapcar 'md-value ks))))) + :value (c? (bwhen (ks (^kids)) + ;(trc "chya" (mapcar 'value ks)) + (apply '+ (mapcar 'value ks))))) (def-cell-test many-useds (let ((i (make-instance 'm-index))) (loop for n below 100 do (push (make-instance 'model :fm-parent i - :md-value (c-in n)) + :value (c-in n)) (kids i))) - (trc "index total" (md-value i)) - (ct-assert (= 4950 (md-value i))))) + (trc "index total" (value i)) + (ct-assert (= 4950 (value i))))) #+test (many-useds) From ktilton at common-lisp.net Sat Nov 4 20:52:01 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 4 Nov 2006 15:52:01 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20061104205201.B4B3053000@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv30831 Modified Files: cells.lpr defpackage.lisp family-values.lisp family.lisp fm-utilities.lisp integrity.lisp test.lisp Log Message: md-value -> value --- /project/cells/cvsroot/cells/cells.lpr 2006/10/17 21:28:39 1.22 +++ /project/cells/cvsroot/cells/cells.lpr 2006/11/04 20:52:01 1.23 @@ -23,11 +23,7 @@ (make-instance 'module :name "md-utilities.lisp") (make-instance 'module :name "family.lisp") (make-instance 'module :name "fm-utilities.lisp") - (make-instance 'module :name "family-values.lisp") - (make-instance 'module :name - "doc\\01-Cell-basics.lisp") - (make-instance 'module :name - "doc\\motor-control.lisp")) + (make-instance 'module :name "family-values.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\\utils-kt")) :libraries nil --- /project/cells/cvsroot/cells/defpackage.lisp 2006/10/17 21:28:39 1.8 +++ /project/cells/cvsroot/cells/defpackage.lisp 2006/11/04 20:52:01 1.9 @@ -52,7 +52,7 @@ #: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 + #:mkpart #:make-kid #:the-kids #:nsib #:value #:^value #:.value #:kids #:^kids #:.kids #:cells-reset #:upper #:fm-max #:nearest #:fm-min-kid #:fm-max-kid #:mk-kid-slot #:def-kid-slots #:find-prior #:fm-pos #:kid-no #:fm-includes #:fm-ascendant-common #:fm-kid-containing #:fm-find-if #:fm-ascendant-if #:c-abs #:fm-collect-if #:psib --- /project/cells/cvsroot/cells/family-values.lisp 2006/05/20 06:32:19 1.4 +++ /project/cells/cvsroot/cells/family-values.lisp 2006/11/04 20:52:01 1.5 @@ -30,7 +30,7 @@ :reader kv-collector) (kid-values :initform (c? (when (kv-collector self) - (funcall (kv-collector self) (^md-value)))) + (funcall (kv-collector self) (^value)))) :accessor kid-values :initarg :kid-values) --- /project/cells/cvsroot/cells/family.lisp 2006/11/03 13:37:10 1.15 +++ /project/cells/cvsroot/cells/family.lisp 2006/11/04 20:52:01 1.16 @@ -19,12 +19,12 @@ (in-package :cells) (eval-when (:compile-toplevel :execute :load-toplevel) - (export '(model md-value family kids kid1 ^k1 kid2 ^k2 last-kid ^k-last perishable))) + (export '(model value family kids kid1 ^k1 kid2 ^k2 last-kid ^k-last perishable))) (defmodel model () ((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name) (.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent) - (.md-value :initform nil :accessor md-value :initarg :md-value))) + (.value :initform nil :accessor value :initarg :value))) (defmethod fm-parent (other) @@ -90,6 +90,11 @@ (if (typep ,self ',type) ,self (upper ,self ,type))))) (defun kid1 (self) (car (kids self))) + +(export! first-born-p) +(defun first-born-p (self) + (eq self (kid1 .parent))) + (defun kid2 (self) (cadr (kids self))) (defmacro ^k1 () `(kid1 self)) (defmacro ^k2 () `(kid2 self)) --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/11/03 13:37:10 1.13 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/11/04 20:52:01 1.14 @@ -403,7 +403,7 @@ (export! fmv) (defmacro fmv (name) - `(md-value (fm-other ,name))) + `(value (fm-other ,name))) (defmacro fm-otherx (md-name &key (starting 'self) skip-tree) (if (eql starting 'self) @@ -448,7 +448,7 @@ :global-search t))) (defmacro fm^v (id) - `(md-value (fm^ ,id))) + `(value (fm^ ,id))) (defmacro fm? (md-name &optional (starting 'self) (global-search t)) `(fm-find-one ,starting ,(if (consp md-name) @@ -466,7 +466,7 @@ :global-search nil))) (defmacro fm!v (id) - `(md-value (fm! ,id))) + `(value (fm! ,id))) (defmacro fm-other?! (md-name &optional (starting 'self)) `(fm-find-one ,starting ,(if (consp md-name) --- /project/cells/cvsroot/cells/integrity.lisp 2006/10/17 21:28:39 1.14 +++ /project/cells/cvsroot/cells/integrity.lisp 2006/11/04 20:52:01 1.15 @@ -30,12 +30,18 @@ "Invalid second value to with-integrity: ~a" opcode)) `(call-with-integrity ,opcode ,defer-info (lambda () , at body))) -(export! with-c-change) +(export! with-c-change with-c-changes) (defmacro with-c-change (id &body body) `(with-integrity (:change ,id) , at body)) +(defmacro with-c-changes (id &rest change-forms) + `(with-c-change ,id + ,(car change-forms) + ,(when (cdr change-forms) + `(with-c-changes ,id ,@(cdr change-forms))))) + (defun integrity-managed-p () *within-integrity*) @@ -68,6 +74,8 @@ (or (ufb-queue opcode) (cdr (car (push (cons opcode (make-fifo-queue)) *unfinished-business*))))) +(defparameter *no-tell* nil) + (defun ufb-add (opcode continuation) (assert (find opcode *ufb-opcodes*)) (when (and *no-tell* (eq opcode :tell-dependents)) @@ -83,7 +91,7 @@ while task do (trc nil "unfin task is" opcode task) (funcall task))) -(defparameter *no-tell* nil) + (defun finish-business () (when *stop* (return-from finish-business)) (tagbody --- /project/cells/cvsroot/cells/test.lisp 2006/06/23 01:04:56 1.8 +++ /project/cells/cvsroot/cells/test.lisp 2006/11/04 20:52:01 1.9 @@ -97,16 +97,16 @@ (defmodel m-index (family) () (:default-initargs - :md-value (c? (bwhen (ks (^kids)) - (apply '+ (mapcar 'md-value ks)))))) + :value (c? (bwhen (ks (^kids)) + (apply '+ (mapcar 'value ks)))))) (def-cell-test many-useds (let ((i (make-instance 'm-index))) (loop for n below 100 do (push (make-instance 'model - :md-value (c-in n)) + :value (c-in n)) (kids i))) - (trc "index total" (md-value i)))) + (trc "index total" (value i)))) (defmodel m-null () ((aa :initform nil :cell nil :initarg :aa :accessor aa))) From ktilton at common-lisp.net Sat Nov 4 20:52:01 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 4 Nov 2006 15:52:01 -0500 (EST) Subject: [cells-cvs] CVS cells/doc Message-ID: <20061104205201.EFC8A53001@common-lisp.net> Update of /project/cells/cvsroot/cells/doc In directory clnet:/tmp/cvs-serv30831/doc Modified Files: 01-Cell-basics.lisp Log Message: md-value -> value --- /project/cells/cvsroot/cells/doc/01-Cell-basics.lisp 2006/05/20 06:32:19 1.4 +++ /project/cells/cvsroot/cells/doc/01-Cell-basics.lisp 2006/11/04 20:52:01 1.5 @@ -309,10 +309,10 @@ parent slot, which gets used along with a family's kids slot to form simple trees navigable up and down. -model-objects also have slots for md-name and md-value (don't +model-objects also have slots for md-name and value (don't worry camelcase-haters, that is a declining feature of my code). md-name lets the family trees we build be treated as namespaces. -md-value just turns out to be very handy for a lot of things. for +value just turns out to be very handy for a lot of things. for example, a check-box instance needs some place to indicate its boolean state. @@ -323,7 +323,7 @@ rules we write, and the side-effects we specify via observer functions. the silly example below just shows the summer (that which sums) getting -a new md-value as the kids change, along with some observer output. in real-world +a new value as the kids change, along with some observer output. in real-world applications, where kids represent gui elements often dependent on each other, vastly more can transpire before a simple push into a kids slot has run its course. @@ -335,15 +335,15 @@ () (:default-initargs :kids (c-in nil) ;; or we cannot add any addend kids later - :md-value (c? (reduce #'+ (kids self) + :value (c? (reduce #'+ (kids self) :initial-value 0 - :key #'md-value)))) + :key #'value)))) -(defobserver md-value ((self summer)) +(defobserver value ((self summer)) (trc "the sum of the values of the kids is" new-value)) (defobserver .kids ((self summer)) - (trc "the values of the kids are" (mapcar #'md-value new-value))) + (trc "the values of the kids are" (mapcar #'value new-value))) ;----------------------------------------------------------- ; now just evaluate each of the following forms one by one, @@ -364,7 +364,7 @@ (push (make-instance 'model :fm-parent *f1* - :md-value 1) (kids *f1*)) + :value 1) (kids *f1*)) #| observe: 0> the values of the kids are (1) @@ -376,7 +376,7 @@ (push (make-instance 'model :fm-parent *f1* - :md-value 2) (kids *f1*)) + :value 2) (kids *f1*)) #| observe: 0> the values of the kids are (2 1) From ktilton at common-lisp.net Sat Nov 4 20:52:02 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 4 Nov 2006 15:52:02 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20061104205202.3898053000@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv30831/utils-kt Modified Files: flow-control.lisp Log Message: md-value -> value --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/10/02 02:38:32 1.7 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/11/04 20:52:02 1.8 @@ -31,7 +31,7 @@ (defun min-if (v1 v2) (if v1 (if v2 (min v1 v2) v1) v2)) -(export! list-flatten! tree-flatten) +(export! list-flatten! tree-flatten list-insertf subseq-contiguous-p) (defun list-flatten! (&rest list) (if (consp list) @@ -67,6 +67,22 @@ (declare (dynamic-extent ,fn-name)) , at body)) +(defmacro list-insertf (place item &key after) + (let ((list (gensym)) + (afterv (gensym)) + (afters (gensym))) + `(let* ((,list ,place) + (,afterv ,after) + (,afters (when ,afterv (member ,after ,list)))) + (assert (or (null ,afterv) ,afters) () "list-insertf after ~a not in list ~a" ,afterv ,list) + (setf ,place + (if ,afterv + (append (ldiff ,list ,afters) + (list ,afterv) + (list ,item) + (cdr ,afters)) + (append ,list (list ,item))))))) + (defun intern$ (&rest strings) (intern (apply #'concatenate 'string strings))) From ktilton at common-lisp.net Sat Nov 4 20:53:08 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 4 Nov 2006 15:53:08 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20061104205308.9DC8C751A8@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv31024 Modified Files: button.lisp composites.lisp demos.lisp entry.lisp fileevent.lisp lotsa-widgets.lisp ltktest-ci.lisp menu.lisp multichoice.lisp togl.lisp Log Message: New "lite" versions of Celtk without all the Tk widgets, for PureCello --- /project/cells/cvsroot/Celtk/button.lisp 2006/11/03 13:37:50 1.6 +++ /project/cells/cvsroot/Celtk/button.lisp 2006/11/04 20:53:08 1.7 @@ -66,12 +66,12 @@ -offvalue -onvalue) (:default-initargs :id (gentemp "CK") - :md-value (c-in nil) + :value (c-in nil) :tk-variable (c? (^path)) :on-command (lambda (self) - (setf (^md-value) (not (^md-value)))))) + (setf (^value) (not (^value)))))) -(defobserver .md-value ((self checkbutton)) +(defobserver .value ((self checkbutton)) (tk-format `(:variable ,self) "set ~(~a~) ~a" (path self) (if new-value 1 0))) ; --- radiobutton ------------------------------------- --- /project/cells/cvsroot/Celtk/composites.lisp 2006/10/02 02:56:01 1.19 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/11/04 20:53:08 1.20 @@ -113,6 +113,9 @@ on-key-down on-key-up) +(export! .control-key-p) +(define-symbol-macro .control-key-p (find :control (keyboard-modifiers .tkw))) + (defmethod make-tk-instance ((self window)) (setf (gethash (^path) (dictionary .tkw)) self)) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/11/03 13:37:50 1.25 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/11/04 20:53:08 1.26 @@ -26,7 +26,7 @@ :kids (c? (the-kids (mk-stack ("stack" :packing (c?pack-self "-side bottom") :relief 'ridge) (mk-entry :id :my-entry - :md-value (c-in "abc")) + :value (c-in "abc")) (mk-row ( "row" #| :packing (c?pack-self "-side bottom") |# :relief 'ridge) (mk-label :text (c? (format nil "selection: ~a" (selection (fm^ :my-selector))))) (mk-label :text "Labeltext") @@ -81,13 +81,13 @@ :kids (c? (the-kids (mk-text-widget :id :my-text - :md-value (c?n "[bzbzbzbz]") + :value (c?n "[bzbzbzbz]") :height 8 :width 25) (make-instance 'entry :id :entree :fm-parent *parent* - :md-value (c-in "Boots")) + :value (c-in "Boots")) ;;; (make-instance 'button ;;; :fm-parent *parent* ;;; :text "read" @@ -100,7 +100,7 @@ ;;; (trc "we got scale callbacks" self (parse-integer value))))) ;;; (mk-spinbox ;;; :id :spin-pkg - ;;; :md-value (c-in "cells") ;;(cells::c?n "cells") + ;;; :value (c-in "cells") ;;(cells::c?n "cells") ;;; :tk-values (mapcar 'down$ ;;; (sort (mapcar 'package-name ;;; (list-all-packages)) @@ -135,7 +135,7 @@ (mk-stack (:packing (c?pack-self)) (mk-spinbox :id :spin-pkg - :md-value (c-in "cells") ;;(cells::c?n "cells") + :value (c-in "cells") ;;(cells::c?n "cells") :tk-values (mapcar 'down$ (sort (mapcar 'package-name (list-all-packages)) @@ -145,7 +145,7 @@ :list-height 6 :list-item-keys (c? (trc "enter item keys" self (fm^ :spin-pkg)) (let* ((spinner (fm^ :spin-pkg)) - (item (when spinner (md-value spinner))) + (item (when spinner (value spinner))) (pkg (find-package (string-upcase item)))) (when pkg (loop for sym being the symbols in pkg @@ -156,7 +156,7 @@ :list-item-factory (lambda (sym) (make-instance 'listbox-item :fm-parent *parent* - :md-value sym + :value sym :item-text (down$ (symbol-name sym))))) (mk-label :text (c? (selection (fm^ :spinpkg-sym-list))))))))) @@ -194,16 +194,16 @@ (defmodel font-view (frame-stack) () (:default-initargs - :md-value (c? (tk-eval-list "font families")) + :value (c? (tk-eval-list "font families")) :pady 2 :padx 4 :packing-side 'left :layout-anchor 'nw :kids (c? (the-kids (mk-spinbox :id :font-face - :md-value (c-in (car (^md-value))) - :tk-values (c? (md-value .parent))) + :value (c-in (car (^value))) + :tk-values (c? (value .parent))) (mk-scale :id :font-size - :md-value (c-in 14) + :value (c-in 14) :tk-label "Font Size" :from 7 :to 24 :orient 'horizontal) @@ -211,8 +211,8 @@ :text "Four score seven years ago today" :wraplength 600 :tkfont (c? (list ;; format nil "{{~{~a~^ ~}} ~a}" ;; eg, {{wp greek century} 24} - (md-value (fm^ :font-face)) - (md-value (fm^ :font-size))))))))) + (value (fm^ :font-face)) + (value (fm^ :font-size))))))))) #| 06-02-14 following stuff not resurrected after latest revisions to Celtk @@ -224,12 +224,12 @@ (defmodel file-open (toplevel) () (:default-initargs - :md-value (c? (directory "\\windows\\fonts\\*.ttf")) + :value (c? (directory "\\windows\\fonts\\*.ttf")) :pady 2 :padx 4 :kids (c? (the-kids (mk-spinbox :id :font-face - :md-value (c-in (car (^md-value))) - :tk-values (c? (mapcar 'pathname-name (md-value .parent)))) + :value (c-in (car (^value))) + :tk-values (c? (mapcar 'pathname-name (value .parent)))) (mk-button-ex ("Open" (progn (tk-format `(:destroy ,self) "destroy ~a" (path (upper self toplevel))) (not-to-be (upper self toplevel)))) --- /project/cells/cvsroot/Celtk/entry.lisp 2006/11/03 13:37:50 1.16 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/11/04 20:53:08 1.17 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.16 2006/11/03 13:37:50 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.17 2006/11/04 20:53:08 ktilton Exp $ (in-package :Celtk) @@ -51,10 +51,10 @@ ;; assuming write op, but data field shows that (let ((new-value (tcl-get-var *tki* (^path) (var-flags :TCL-NAMESPACE-ONLY)))) - (unless (string= new-value (^md-value)) - (setf (^md-value) new-value)))))))) + (unless (string= new-value (^value)) + (setf (^value) new-value)))))))) - :md-value (c-in ""))) + :value (c-in ""))) (defmethod md-awaken :after ((self entry)) ;; move this to a traces slot on widget (with-integrity (:client `(:trace ,self)) @@ -63,10 +63,10 @@ ;;; /// this next replicates the handling of tk-mirror-variable because ;;; those leverage the COMMAND mechanism, which entry lacks ;; -(defobserver .md-value ((self entry)) +(defobserver .value ((self entry)) (when new-value (unless (string= new-value old-value) - (trc nil "md-value output" self new-value) + (trc nil "value output" self new-value) (tcl-set-var *tki* (^path) new-value (var-flags :TCL-NAMESPACE-ONLY))))) (deftk text-widget (widget) @@ -86,7 +86,7 @@ -undo -width -wrap) (:default-initargs :id (gentemp "TXT") - :md-value (c-in "") + :value (c-in "") :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) :modified (c-in nil) @@ -101,10 +101,10 @@ )))) (defmethod clear ((self text-widget)) - (setf (md-value self) nil)) + (setf (value self) nil)) -(defobserver .md-value ((self text-widget)) - (trc nil "md-value output" self new-value) +(defobserver .value ((self text-widget)) + (trc nil "value output" self new-value) (with-integrity (:client `(:variable ,self)) (tk-format-now "~a delete 1.0 end" (^path)) (when (plusp (length new-value)) --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/06/03 12:12:19 1.8 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2006/11/04 20:53:08 1.9 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.8 2006/06/03 12:12:19 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.9 2006/11/04 20:53:08 ktilton Exp $ ;;; --------------------------------------------------------------------------- ;;; =========================================================================== @@ -543,7 +543,7 @@ (let ((data (read-line stream nil nil nil))) (trc "*** USRF: data = " data) (if data - (setf (md-value (fm-other :receive-window)) data) + (setf (value (fm-other :receive-window)) data) (funcall (^eof-fn) self))))) (defmodel fileevent-test-window (window) @@ -555,7 +555,7 @@ :pady 10) (mk-text-widget :id :receive-window ;:state 'disabled - :md-value (c-in "") + :value (c-in "") :height 10 :width 80 :borderwidth 2 --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/11/03 13:37:50 1.6 +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/11/04 20:53:08 1.7 @@ -46,7 +46,7 @@ (mk-stack () (mk-text-widget :id :my-text - :md-value (c?n "hello, world") + :value (c?n "hello, world") :height 8 :width 25) @@ -60,14 +60,14 @@ (mk-row () (mk-checkbutton :id :check-me :text "Check Me" - :md-value (c-in t)) + :value (c-in t)) (mk-label :text (c? (if (fm^v :check-me) "checked" "unchecked")))) (mk-row () (mk-button-ex ("Time now?" (setf (fm^v :push-time) (get-universal-time)))) - (mk-label :text (c? (time-of-day (^md-value))) + (mk-label :text (c? (time-of-day (^value))) :id :push-time - :md-value (c-in (get-universal-time)))) + :value (c-in (get-universal-time)))) (style-by-edit-menu) @@ -98,7 +98,7 @@ (mk-stack () (mk-spinbox :id :spin-pkg - :md-value (cells::c?n "cells") + :value (cells::c?n "cells") :tk-values (mapcar 'down$ (sort (mapcar 'package-name (list-all-packages)) @@ -107,7 +107,7 @@ :id :spinpkg-sym-list :list-height 6 :list-item-keys (c? (let* ((spinner (fm^ :spin-pkg)) - (item (when spinner (md-value spinner))) + (item (when spinner (value spinner))) (pkg (find-package (string-upcase item)))) (when pkg (loop for sym being the symbols in pkg @@ -118,7 +118,7 @@ :list-item-factory (lambda (sym) (make-instance 'listbox-item :fm-parent *parent* - :md-value sym + :value sym :item-text (down$ (symbol-name sym))))))) (defun duelling-scrolled-lists () @@ -131,7 +131,7 @@ :list-item-factory (lambda (pkg) (make-instance 'listbox-item :fm-parent *parent* - :md-value pkg + :value pkg :item-text (down$ (package-name pkg))))) (mk-scrolled-list :id :pkg-sym-list @@ -142,7 +142,7 @@ collecting sym))) :list-item-factory (lambda (sym) (make-instance 'listbox-item - :md-value sym + :value sym :fm-parent *parent* :item-text (down$ (symbol-name sym))))))) @@ -190,7 +190,7 @@ :entry-values (c? (subseq (tk-eval-list "font families") 4 10))) (mk-scale :id :font-size - :md-value (c-in 14) + :value (c-in 14) :tk-label "Font Size" :from 7 :to 24 :orient 'horizontal)) @@ -201,7 +201,7 @@ :tk-justify 'left :tkfont (c? (list (selection (fm^ :font-face)) - (md-value (fm^ :font-size))))))) + (value (fm^ :font-size))))))) (defun demo-all-menubar () (mk-menubar @@ -219,7 +219,7 @@ (mk-menu-entry-command :label "Close" :command "{destroy .}") (mk-menu-entry-separator) (mk-menu-entry-command :label "Quit" - :state (c? (if t ;; (md-value (fm^ :check-me)) + :state (c? (if t ;; (value (fm^ :check-me)) 'normal 'disabled)) :command "tk_getOpenFile"))))))) ;; 'exit' in production, but under dev would take out Lisp IDE (mk-menu-entry-cascade @@ -259,6 +259,6 @@ collecting (mk-menu-entry-radiobutton :label label :value value)))))))) (mk-menu-entry-separator) (mk-menu-entry-checkbutton :id :app-font-italic :label "Italic") - (mk-menu-entry-checkbutton :id :app-font-bold :label "Bold" :md-value (c-in t)))))))))))) + (mk-menu-entry-checkbutton :id :app-font-bold :label "Bold" :value (c-in t)))))))))))) --- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/10/28 18:21:52 1.10 +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/11/04 20:53:08 1.11 @@ -216,7 +216,7 @@ ; solution to this riddle. ; (mk-entry-numeric :id :point-ct - :md-value (c-in "42") + :value (c-in "42") ; ; to help motivate "why Cells?" a little more, we deviate from ltktest 'classic" and ; start having the widgets take more interesting effect: The entry field now determines the number @@ -240,7 +240,7 @@ ; from outside the model. ; (handler-case - (let ((num (parse-integer (^md-value)))) + (let ((num (parse-integer (^value)))) (cond ((< num 2) (list (format nil "Yo, Euclid, at least two, not: ~a!!" num))) @@ -256,7 +256,7 @@ ; As you edit the field, if you key in an invalid (non-digit) character, the background ; immediately turns red. Delete it and it reverts to the default. ; - ; The interesting question is, how does the md-value slot of the Lisp instance stay + ; The interesting question is, how does the value slot of the Lisp instance stay ; current with the text being edited in the Tk entry widget? Here we have a fundamental ; difference between Ltk and Celtk. Ltk lets Tk take care of everything, including ; storing the data. eg, (text my-entry) is an accessor call that asks Tk the value of @@ -265,7 +265,7 @@ ; by having datapoints watching other datapoints, so we want data in the Lisp domain ; changing automatically as it changes on the TK side (such as when the user is actually ; typing in the entry widget). See the entry class to see how it uses the TCL "trace write" - ; mechanism to keep the Lisp md-value slot abreast of the Tk entry text configuration + ; mechanism to keep the Lisp value slot abreast of the Tk entry text configuration ; keystroke by keystroke. ; ; I added the :user-errors rule above to demonstrate the mechanism in action. Click @@ -275,28 +275,28 @@ (mk-button-ex ("Print" (format t "~&User wants to see ~A points" (fm^v :point-ct)))) ; - ; (fm^v :point-ct) -> (md-value (fm^ :point-ct)) + ; (fm^v :point-ct) -> (value (fm^ :point-ct)) ; - ; The idea being that every Cells model object has an md-value slot bearing the value + ; The idea being that every Cells model object has an value slot bearing the value ; of the thing being modeled. Here, the entry widget is modelling a place for users - ; to supply information to an application, and the md-value slot is a good place to + ; to supply information to an application, and the value slot is a good place to ; keep that information. ; - ; Thus each class uses md-value to hold something different, but in all cases it is + ; Thus each class uses value to hold something different, but in all cases it is ; the current value of whatever the instance of that class is understood to hold. ; (mk-button-ex ("Reset" (setf (fm^v :point-ct) "42"))) ; ; Driving home this point again, in Ltk one would SETF (text my-entry) and the ; SETF method would communicate with Tk to make the change to the Tk widget -text - ; configuration. In Celtk, the md-value slot of the entry gets changed (possibly + ; configuration. In Celtk, the value slot of the entry gets changed (possibly ; triggering other slots to update, which is why we do not just talk to Tk) and ; then that value gets propagated to Tk via "set ". Because ; the textVariable for every entry is the entry itself, the text of the entry ; then changes. If that sounds weird, what we are actually doing is tapping into - ; the fact that Tk to a large degree takes the same approach as Cells does with md-value: + ; the fact that Tk to a large degree takes the same approach as Cells does with value: ; in Cells, we think of model instances as wrapping some model-specific - ; value, which is held in the md-value slot of the model instance. Tk simply + ; value, which is held in the value slot of the model instance. Tk simply ; allows a widget path to be a global variable. Furthermore, as the company name ; ActiveState suggests, Tk also provides automatic propagation: change the ; variable, and anyone with that as its textVariable also changes. @@ -439,7 +439,7 @@ ((num-parse :initarg :num-parse :accessor num-parse :initform (c? (eko ("numparse") (handler-case - (parse-integer (^md-value)) + (parse-integer (^value)) (parse-error (c) (princ-to-string c)))))) (num-value :initarg :num-value :accessor num-value @@ -447,7 +447,7 @@ (^num-parse) (or .cache 42))))) (:default-initargs - :md-value "42" + :value "42" :user-errors (c? (unless (numberp (^num-parse)) (^num-parse))))) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/11/03 13:37:50 1.17 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/11/04 20:53:08 1.18 @@ -192,13 +192,13 @@ -offvalue -onvalue) (:default-initargs - :md-value (c-in nil) + :value (c-in nil) :tk-variable (c? (format nil "~a.~(~a~)" (path .parent)(md-name self))) :on-command (lambda (self) - (setf (^md-value) (not (^md-value)))))) + (setf (^value) (not (^value)))))) -(defobserver .md-value ((self menu-entry-checkbutton)) - (trc nil "defobserver md-value menu-entry-checkbutton" self new-value old-value-boundp) +(defobserver .value ((self menu-entry-checkbutton)) + (trc nil "defobserver value menu-entry-checkbutton" self new-value old-value-boundp) (when (and new-value (not old-value-boundp)) (tk-format `(:variable ,self) "set ~a ~a" (^tk-variable) (if new-value 1 0)))) --- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/11/03 13:37:50 1.11 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/11/04 20:53:08 1.12 @@ -34,18 +34,18 @@ -tickinterval -to (-tk-variable nil)) (:default-initargs :id (gentemp "SCL") - :md-value (c-in nil) + :value (c-in nil) :tk-variable nil ;;(c? (^path)) :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) :on-command (lambda (self value) ;; (trc "hi scale" self value) - (setf (^md-value) (parse-integer value))))) + (setf (^value) (parse-integer value))))) (defmethod make-tk-instance :after ((self scale)) "Still necessary?" - (when (^md-value) - (tk-format `(:variable ,self) "~a set ~a" (^path) (^md-value)))) + (when (^value) + (tk-format `(:variable ,self) "~a set ~a" (^path) (^value)))) ; --- listbox -------------------------------------------------------------- @@ -70,11 +70,11 @@ (ListboxSelect (let ((selection (parse-integer (tk-eval "~a curselection" (^path))))) (setf (selection (selector self)) - (md-value (elt (^kids) selection))))))))))) + (value (elt (^kids) selection))))))))))) (defmodel listbox-item (tk-object) ((item-text :initarg :item-text :accessor item-text - :initform (c? (format nil "~a" (^md-value)))))) + :initform (c? (format nil "~a" (^value)))))) (defmethod make-tk-instance ((self listbox-item)) (trc nil "make-tk-instance listbox-item insert" self) @@ -106,22 +106,22 @@ -troughcolor -underline -xscrollcommand -validate -validatecommand (tk-values -values) -width -wrap) (:default-initargs - :md-value (c-in nil) + :value (c-in nil) :id (gentemp "SPN") :textVariable (c? (^path)) :xscrollcommand (c-in nil) :command (c? (format nil "do-on-command ~a %s" (^path))) :on-command (c? (lambda (self text) (eko ("variable mirror command fired !!!!!!!" text) - (setf (^md-value) text)))))) + (setf (^value) text)))))) -(defobserver .md-value ((self spinbox)) +(defobserver .value ((self spinbox)) (when new-value (tk-format `(:variable ,self) "set ~a ~a" (^path) (tk-send-value new-value)))) (defobserver initial-value ((self spinbox)) (when new-value (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value) - (setf (^md-value) new-value))) + (setf (^value) new-value))) --- /project/cells/cvsroot/Celtk/togl.lisp 2006/10/28 18:21:52 1.22 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/11/04 20:53:08 1.23 @@ -194,8 +194,11 @@ (def-togl-callback create () (trc "___________________ TOGL SET UP _________________________________________" togl-ptr ) - #+cl-ftgl (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready - #+kt-opengl (kt-opengl:kt-opengl-reset) + ; + ; just comment out these two lines if not using Cello + ; + (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready + (kt-opengl:kt-opengl-reset) (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred (setf (togl-ptr-set self) togl-ptr) ;; this gets deferred, which is OK (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self)) From ktilton at common-lisp.net Sat Nov 4 20:53:08 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 4 Nov 2006 15:53:08 -0500 (EST) Subject: [cells-cvs] CVS Celtk/gears Message-ID: <20061104205308.D1A64751A8@common-lisp.net> Update of /project/cells/cvsroot/Celtk/gears In directory clnet:/tmp/cvs-serv31024/gears Modified Files: gears.lisp Log Message: New "lite" versions of Celtk without all the Tk widgets, for PureCello --- /project/cells/cvsroot/Celtk/gears/gears.lisp 2006/06/07 22:13:41 1.2 +++ /project/cells/cvsroot/Celtk/gears/gears.lisp 2006/11/04 20:53:08 1.3 @@ -37,12 +37,12 @@ (mk-row () (mk-label :text "Spin delay (ms):") (mk-entry :id :vtime - :md-value (c-in "100")) + :value (c-in "100")) (mk-button-ex (" Quit " (tk-eval "destroy .")))) (make-instance 'gears :fm-parent *parent* :width 400 :height 400 - :timer-interval (c? (let ((n$ (md-value (fm-other :vtime)))) + :timer-interval (c? (let ((n$ (value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" :event-handler (c? (lambda (self xe) From ktilton at common-lisp.net Mon Nov 13 05:28:08 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 13 Nov 2006 00:28:08 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20061113052808.B0BB230029@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv10869 Modified Files: cell-types.lisp cells.lpr constructors.lisp defmodel.lisp family.lisp integrity.lisp md-slot-value.lisp model-object.lisp propagate.lisp slot-utilities.lisp Log Message: --- /project/cells/cvsroot/cells/cell-types.lisp 2006/11/03 13:37:10 1.22 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/11/13 05:28:08 1.23 @@ -44,8 +44,10 @@ ;_____________________ print __________________________________ +#+sigh (defmethod print-object :before ((c cell) stream) - (unless (or *stop* *print-readably*) + (declare (ignorable stream)) + #+shhh (unless (or *stop* *print-readably*) (format stream "[~a~a:" (if (c-inputp c) "i" "?") (cond ((null (c-model c)) #\0) @@ -53,16 +55,19 @@ ((not (c-currentp c)) #\#) (t #\space))))) - (defmethod print-object ((c cell) stream) - (if (or *stop* *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 (and (c-model c)(md-name (c-model c))) :anonmd))))) + (declare (ignorable stream)) + (unless *stop* + (let ((*print-circle* t)) + #+failsafe (format stream "~a/~a" (c-model c)(c-slot-name c)) + (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)) + (bwhen (md (c-model c)) (md-name md) :anonmd))))))) (defmethod trcp :around ((c cell)) (or (c-debug c) @@ -100,13 +105,11 @@ ; ; ;; good q: what does (setf 'x) return? historically nil, but...? ; + ;;(trcx bingo-ephem c) (with-integrity (:ephemeral-reset 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 caller in (c-callers c) - do (calculate-and-link caller))))) + (setf (c-value c) nil)))) ; ----------------------------------------------------- @@ -170,5 +173,3 @@ (defmethod c-print-value (c stream) (declare (ignore c stream))) - - --- /project/cells/cvsroot/cells/cells.lpr 2006/11/04 20:52:01 1.23 +++ /project/cells/cvsroot/cells/cells.lpr 2006/11/13 05:28:08 1.24 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- (in-package :cg-user) @@ -23,7 +23,8 @@ (make-instance 'module :name "md-utilities.lisp") (make-instance 'module :name "family.lisp") (make-instance 'module :name "fm-utilities.lisp") - (make-instance 'module :name "family-values.lisp")) + (make-instance 'module :name "family-values.lisp") + (make-instance 'module :name "variables.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\\utils-kt")) :libraries nil --- /project/cells/cvsroot/cells/constructors.lisp 2006/11/03 13:37:10 1.12 +++ /project/cells/cvsroot/cells/constructors.lisp 2006/11/13 05:28:08 1.13 @@ -92,7 +92,7 @@ :lazy :until-asked :rule (c-lambda , at body))) -(export! c?dbg c_?dbg) +(export! c?dbg c_?dbg c-input-dbg) (defmacro c_?dbg (&body body) "Lazy until asked, then eagerly propagating" --- /project/cells/cvsroot/cells/defmodel.lisp 2006/10/02 02:38:31 1.10 +++ /project/cells/cvsroot/cells/defmodel.lisp 2006/11/13 05:28:08 1.11 @@ -118,18 +118,18 @@ (find-class ',class)))) (defun defmd-canonicalize-slot (slotname - &key - (cell nil cell-p) + &key + (cell nil cell-p) (owning nil owning-p) (type nil type-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)) + (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)) --- /project/cells/cvsroot/cells/family.lisp 2006/11/04 20:52:01 1.16 +++ /project/cells/cvsroot/cells/family.lisp 2006/11/13 05:28:08 1.17 @@ -41,6 +41,17 @@ (define-symbol-macro .parent (fm-parent self)) +(defmethod md-name (other) + (trc "yep other md-name" other (type-of other)) + other) + +(defmethod md-name ((nada null)) + (unless (c-stopped) + (c-stop :md-name-on-null) + (break "md-name called on nil"))) + +(defmethod md-name ((sym symbol)) sym) + (defmethod shared-initialize :around ((self model) slotnames &rest initargs &key fm-parent) (declare (ignorable initargs slotnames fm-parent)) @@ -189,12 +200,5 @@ (declare (ignorable self)) (list , at slot-defs))) -(defmethod md-name (other) - (trc "yep other md-name" other (type-of other)) - other) -(defmethod md-name ((nada null)) - (unless (c-stopped) - (c-stop :md-name-on-null) - (break "md-name called on nil"))) --- /project/cells/cvsroot/cells/integrity.lisp 2006/11/04 20:52:01 1.15 +++ /project/cells/cvsroot/cells/integrity.lisp 2006/11/13 05:28:08 1.16 @@ -24,24 +24,22 @@ :ephemeral-reset :change)) -(defmacro with-integrity ((&optional opcode defer-info) &rest body) +(defmacro with-integrity ((&optional opcode defer-info debug) &rest body) (when opcode (assert (find opcode *ufb-opcodes*) () "Invalid second value to with-integrity: ~a" opcode)) - `(call-with-integrity ,opcode ,defer-info (lambda () , at body))) + `(call-with-integrity ,opcode ,defer-info (lambda (opcode defer-info) + (declare (ignorable opcode defer-info)) + ,(when debug + `(trc "integrity action entry" opcode defer-info ',body)) + , at body))) -(export! with-c-change with-c-changes) +(export! with-cc) -(defmacro with-c-change (id &body body) +(defmacro with-cc (id &body body) `(with-integrity (:change ,id) , at body)) -(defmacro with-c-changes (id &rest change-forms) - `(with-c-change ,id - ,(car change-forms) - ,(when (cdr change-forms) - `(with-c-changes ,id ,@(cdr change-forms))))) - (defun integrity-managed-p () *within-integrity*) @@ -51,7 +49,7 @@ (if *within-integrity* (if opcode (ufb-add opcode (cons defer-info action)) - (funcall action)) + (funcall action opcode defer-info)) (let ((*within-integrity* t) *unfinished-business* *defer-changes*) @@ -62,7 +60,7 @@ (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info) (data-pulse-next (cons opcode defer-info)))) (prog1 - (funcall action) + (funcall action opcode defer-info) (finish-business))))) (defun ufb-queue (opcode) @@ -87,10 +85,10 @@ (ufb-queue op-or-q) op-or-q))) (trc nil "just do it doing" op-or-q) - (loop for (nil . task) = (fifo-pop q) + (loop for (defer-info . task) = (fifo-pop q) while task do (trc nil "unfin task is" opcode task) - (funcall task))) + (funcall task op-or-q defer-info))) (defun finish-business () (when *stop* (return-from finish-business)) @@ -169,7 +167,7 @@ (destructuring-bind (defer-info . task-fn) task-info (trc nil "finbiz: deferred state change" defer-info) (data-pulse-next (list :finbiz defer-info)) - (funcall task-fn) + (funcall task-fn :change defer-info) ; ; to finish this state change we could recursively call (finish-business), but ; a goto let's us not use the stack. Someday I envision code that keeps on --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/11/03 13:37:10 1.31 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/11/13 05:28:08 1.32 @@ -40,12 +40,16 @@ ;; (count-it :md-slot-value slot-name) (if c - (prog1 - (with-integrity () - (ensure-value-is-current c :mdsv nil)) - (when (car *call-stack*) - (record-caller c))) + (cell-read c) (values (bd-slot-value self slot-name) nil))) + +(defun cell-read (c) + (assert (typep c 'cell)) + (prog1 + (with-integrity () + (ensure-value-is-current c :c-read nil)) + (when (car *call-stack*) + (record-caller c)))) (defun chk (s &optional (key 'anon)) (when (eq :eternal-rest (md-state s)) @@ -56,12 +60,12 @@ (count-it :ensure-value-is-current) (trc nil "ensure-value-is-current > entry" c :now-pulse *data-pulse-id* debug-id caller) - (when (eq :eternal-rest (md-state (c-model c))) + (when (and (not (symbolp (c-model c)))(eq :eternal-rest (md-state (c-model c)))) (break "model ~a of cell ~a is dead" (c-model c) 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 + (trc c "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 ;; ((and (c-inputp c) @@ -112,11 +116,11 @@ (trc "calculating cell ~a appears in call stack: ~a" c x stack ))) (setf *stop* t) (c-break "yep" c) - #+not (loop with caller-reiterated - for caller in *call-stack* - until caller-reiterated - do (trc "caller:" caller) - (pprint (cr-code c)) + (loop with caller-reiterated + for caller in *call-stack* + until caller-reiterated + do (trc "caller:" caller) + ;; not necessary (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) @@ -138,6 +142,7 @@ (let ((*call-stack* (cons c *call-stack*)) (*defer-changes* t)) (assert (typep c 'c-ruled)) + (trc nil "calculate-and-link" c) (cd-usage-clear-all c) (multiple-value-prog1 (funcall (cr-rule c) c) --- /project/cells/cvsroot/cells/model-object.lisp 2006/10/17 21:28:39 1.13 +++ /project/cells/cvsroot/cells/model-object.lisp 2006/11/13 05:28:08 1.14 @@ -31,6 +31,8 @@ :documentation "cells supplied but un-whenned or optimized-away") (adopt-ct :initform 0 :accessor adopt-ct))) +(defmethod md-state ((self symbol)) + :alive) ;;; --- md obj initialization ------------------ (defmethod shared-initialize :after ((self model-object) slotnames @@ -67,31 +69,34 @@ (md-awaken self))) )) - - -(defun md-install-cell (self sn c &aux (c-isa-cell (typep c 'cell))) +(defun md-install-cell (self slot-name c &aux (c-isa-cell (typep c 'cell))) ; ; iff cell, init and move into dictionary ; (when c-isa-cell (count-it :md-install-cell) - (setf (c-model c) self - (c-slot-name c) sn - (md-slot-cell self sn) c)) + (c-slot-name c) slot-name + (md-slot-cell self slot-name) c)) ; ; now have the slot really be the slot ; (if c-isa-cell (if (c-unboundp c) - (bd-slot-makunbound self sn) - (setf (slot-value self sn) - (if (c-inputp c) - (c-value c) - nil))) - (setf (slot-value self sn) c))) ;; (in which case "c" is not actually a cell) - + (bd-slot-makunbound self slot-name) + (if self + (setf (slot-value self slot-name) + (when (c-inputp c) (c-value c))) + (setf (symbol-value slot-name) + (when (c-inputp c) (c-value c))))) + ;; note that in this else branch "c" is a misnomer since + ;; the value is not actually a cell + (if self + (setf (slot-value self slot-name) c) + (setf (symbol-value slot-name) c)))) + + ;;; --- awaken -------- ; ; -- do initial evaluation of all ruled slots @@ -163,44 +168,61 @@ (slot-value self slot)) (defmethod md-slot-cell (self slot-name) - (cdr (assoc slot-name (cells self)))) + (if self + (cdr (assoc slot-name (cells self))) + (get slot-name 'cell))) (defun md-slot-cell-type (class-name slot-name) - (bif (entry (assoc slot-name (get class-name :cell-types))) - (cdr entry) - (dolist (super (class-precedence-list (find-class class-name)) - (setf (md-slot-cell-type class-name slot-name) nil)) - (bwhen (entry (assoc slot-name (get (c-class-name super) :cell-types))) - (return-from md-slot-cell-type (setf (md-slot-cell-type class-name slot-name) (cdr entry))))))) + (assert class-name) + (if (eq class-name 'null) + (get slot-name :cell-type) + (bif (entry (assoc slot-name (get class-name :cell-types))) + (cdr entry) + (dolist (super (class-precedence-list (find-class class-name)) + (setf (md-slot-cell-type class-name slot-name) nil)) + (bwhen (entry (assoc slot-name (get (c-class-name super) :cell-types))) + (return-from md-slot-cell-type (setf (md-slot-cell-type class-name slot-name) (cdr entry)))))))) (defun (setf md-slot-cell-type) (new-type class-name slot-name) - (let ((entry (assoc slot-name (get class-name :cell-types)))) - (if entry - (progn - (setf (cdr entry) new-type) - (loop for c in (class-direct-subclasses (find-class class-name)) + (assert class-name) + (if (eq class-name 'null) ;; not def-c-variable + (setf (get slot-name :cell-type) new-type) + (let ((entry (assoc slot-name (get class-name :cell-types)))) + (if entry + (progn + (setf (cdr entry) new-type) + (loop for c in (class-direct-subclasses (find-class class-name)) do (setf (md-slot-cell-type (class-name c) slot-name) new-type))) - (push (cons slot-name new-type) (get class-name :cell-types))))) + (push (cons slot-name new-type) (get class-name :cell-types)))))) (defun md-slot-owning (class-name slot-name) - (bif (entry (assoc slot-name (get class-name :ownings))) - (cdr entry) - (dolist (super (class-precedence-list (find-class class-name))) - (bwhen (entry (assoc slot-name (get (c-class-name super) :ownings))) - (return (setf (md-slot-owning class-name slot-name) (cdr entry))))))) + (assert class-name) + (if (eq class-name 'null) + (get slot-name :owning) + (bif (entry (assoc slot-name (get class-name :ownings))) + (cdr entry) + (dolist (super (class-precedence-list (find-class class-name))) + (bwhen (entry (assoc slot-name (get (c-class-name super) :ownings))) + (return (setf (md-slot-owning class-name slot-name) (cdr entry)))))))) (defun (setf md-slot-owning) (value class-name slot-name) - (let ((entry (assoc slot-name (get class-name :ownings)))) - (if entry - (progn - (setf (cdr entry) value) - (loop for c in (class-direct-subclasses (find-class class-name)) + (assert class-name) + (if (eq class-name 'null) + (setf (get slot-name :owning) value) + + (let ((entry (assoc slot-name (get class-name :ownings)))) + (if entry + (progn + (setf (cdr entry) value) + (loop for c in (class-direct-subclasses (find-class class-name)) do (setf (md-slot-owning (class-name c) slot-name) value))) - (push (cons slot-name value) (get class-name :ownings))))) + (push (cons slot-name value) (get class-name :ownings)))))) -(defmethod md-slot-value-store ((self model-object) slot-name new-value) - (trc nil "md-slot-value-store" slot-name new-value) - (setf (slot-value self slot-name) new-value)) +(defun md-slot-value-store (self slot-name new-value) + (trc nil "md-slot-value-store" self slot-name new-value) + (if self + (setf (slot-value self slot-name) new-value) + (setf (symbol-value slot-name) new-value))) (defun md-slot-cell-flushed (self slot-name) (cdr (assoc slot-name (cells-flushed self)))) @@ -220,17 +242,19 @@ (defmethod cell-when (other) (declare (ignorable other)) nil) (defun (setf md-slot-cell) (new-cell self slot-name) - (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-callers old))) - (c-assert (null (cd-useds old))) - (trc nil "replacing in model .cells" old new-cell self) - (rplacd entry new-cell)) - (progn - (trc nil "adding to model .cells" new-cell self) - (push (cons slot-name new-cell) - (cells self))))) + (if self ;; not on def-c-variables + (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-callers old))) + (c-assert (null (cd-useds old))) + (trc nil "replacing in model .cells" old new-cell self) + (rplacd entry new-cell)) + (progn + (trc nil "adding to model .cells" new-cell self) + (push (cons slot-name new-cell) + (cells self)))) + (setf (get slot-name 'cell) new-cell))) (defun md-map-cells (self type celldo) (map type (lambda (cell-entry) --- /project/cells/cvsroot/cells/propagate.lisp 2006/11/03 13:37:10 1.25 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/11/13 05:28:08 1.26 @@ -73,7 +73,7 @@ (when *stop* (princ #\.)(princ #\!) (return-from c-propagate)) - (trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)) c) + (trc c "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)) c) (trc nil "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c) (when *c-debug* (when (> *c-prop-depth* 250) --- /project/cells/cvsroot/cells/slot-utilities.lisp 2006/05/20 06:32:19 1.3 +++ /project/cells/cvsroot/cells/slot-utilities.lisp 2006/11/13 05:28:08 1.4 @@ -84,7 +84,9 @@ (slot-boundp self slot-name)) (defun bd-slot-makunbound (self slot-name) - (slot-makunbound self slot-name)) + (if slot-name ;; not in def-c-variable + (slot-makunbound self slot-name) + (makunbound self))) #| sample incf (defmethod c-value-incf ((base fpoint) delta) From ktilton at common-lisp.net Mon Nov 13 05:28:08 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 13 Nov 2006 00:28:08 -0500 (EST) Subject: [cells-cvs] CVS cells/gui-geometry Message-ID: <20061113052808.F262A36002@common-lisp.net> Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv10869/gui-geometry Modified Files: geo-family.lisp geometer.lisp gui-geometry.lpr Log Message: --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/11/03 13:37:12 1.10 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/11/13 05:28:08 1.11 @@ -30,19 +30,23 @@ (:horizontal :top)))) (spacing :initarg :spacing :initform 0 :accessor spacing)) (:default-initargs - :lr (c? (+ (^outset) + :lr (c? (if (^collapsed) + (^lr-width 0) + (+ (^outset) + (ecase (orientation self) + (:vertical (loop for k in (^kids) + maximizing (l-width k))) + (:horizontal (bif (lk (last1 (^kids))) + (pr lk) 0)))))) + :lb (c? (if (^collapsed) + (^lb-height 0) + (+ (- (^outset)) (ecase (orientation self) (:vertical (loop for k in (^kids) - maximizing (l-width k))) - (:horizontal (bif (lk (last1 (^kids))) - (pr lk) 0))))) - :lb (c? (+ (- (^outset)) - (ecase (orientation self) - (:vertical (loop for k in (^kids) unless (collapsed k) minimizing (pb k))) - (:horizontal (downs (loop for k in (^kids) - maximizing (l-height k))))))) + (:horizontal (downs (loop for k in (^kids) + maximizing (l-height k)))))))) :kid-slots (lambda (self) (ecase (orientation .parent) (:vertical (list @@ -54,9 +58,10 @@ (:horizontal (list (mk-kid-slot (py :if-missing t) (c? (py-self-centered self (justify .parent)))) - (mk-kid-slot (px) + (mk-kid-slot (px :if-missing t) (c? (px-maintain-pl - (^prior-sib-pr self (spacing .parent))))))))))) + (^prior-sib-pr self (spacing .parent))))))))) + )) (defmodel geo-inline-lazy (geo-zero-tl) ((orientation :initarg :orientation :initform nil :accessor orientation --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/10/28 18:20:54 1.11 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/11/13 05:28:08 1.12 @@ -17,7 +17,7 @@ (in-package #:gui-geometry) (eval-now! - (export '(outset ^outset mkv2 g-offset g-offset-h g-offset-v collapsed ^collapsed))) + (export '(outset ^outset mkv2 g-offset g-offset-h g-offset-v collapsed ^collapsed inset ^inset))) (defmd geometer () px py ll lt lr lb @@ -59,6 +59,8 @@ (mkr (ll geo) (lt geo) (lr geo) (lb geo))) ;---------- gOffset ------------------- + +(export! offset-within) ; (defun offset-within (inner outer &optional dbg) (declare (ignorable dbg)) --- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/10/28 18:20:54 1.6 +++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/11/13 05:28:08 1.7 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Mon Nov 13 05:28:09 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 13 Nov 2006 00:28:09 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20061113052809.33AAA3A017@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv10869/utils-kt Modified Files: utils-kt.lpr Log Message: --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/10/17 21:28:40 1.19 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/11/13 05:28:09 1.20 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Mon Nov 13 05:28:53 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 13 Nov 2006 00:28:53 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20061113052853.1EEE048144@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv11067 Modified Files: Celtk.lisp composites.lisp lotsa-widgets.lisp menu.lisp run.lisp Log Message: --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/10/02 02:56:01 1.36 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/11/13 05:28:52 1.37 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.36 2006/10/02 02:56:01 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.37 2006/11/13 05:28:52 ktilton Exp $ (defpackage :celtk (:nicknames "CTK") @@ -96,12 +96,12 @@ unless (find (car defer-info) +tk-client-task-priority+) do (error "unknown tk client task type ~a in task: ~a " (car defer-info) defer-info)) - (loop for (nil #+not defer-info . task) in (prog1 - (stable-sort (fifo-data user-q) 'tk-user-queue-sort :key 'car) - (fifo-clear user-q)) + (loop for (defer-info . task) in (prog1 + (stable-sort (fifo-data user-q) 'tk-user-queue-sort :key 'car) + (fifo-clear user-q)) do (trc nil "!!! --- tk-user-queue-handler dispatching" defer-info) - (funcall task))) + (funcall task :user-q defer-info))) (defun tk-format-now (fmt$ &rest fmt-args) (unless (find *tkw* *windows-destroyed*) @@ -111,12 +111,12 @@ ; --- debug stuff --------------------------------- ; - (let ((yes '()) + (let ((yes '("pack")) (no '("font"))) (declare (ignorable yes no)) - (when #+not t (and (or ;; (null yes) - (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)) + #+hunh? (not (find-if (lambda (s) (search s tk$)) no))) (format t "~&tk> ~a~%" tk$))) (assert *tki*) --- /project/cells/cvsroot/Celtk/composites.lisp 2006/11/04 20:53:08 1.20 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/11/13 05:28:52 1.21 @@ -97,7 +97,7 @@ (defun app-idle (self) (setf (^app-time) (get-internal-real-time))) -(defmd window (composite-widget decoration-mixin) +(defmd window (toplevel composite-widget decoration-mixin) (title$ (c? (string-capitalize (class-name (class-of self))))) (dictionary (make-hash-table :test 'equalp)) (tkwins (make-hash-table)) @@ -109,12 +109,19 @@ tkfonts-to-load tkfont-sizes-to-load (tkfont-info (tkfont-info-loader)) + start-up-fn + close-fn initial-focus + (focus-state (c-in nil) :documentation "This is about the window having the focus on the desktop, not the key focus. +Actually holds last event code, :focusin or :focusout") on-key-down - on-key-up) + on-key-up + :width (c?n 800) + :height (c?n 600)) -(export! .control-key-p) +(export! .control-key-p .alt-key-p focus-state ^focus-state) (define-symbol-macro .control-key-p (find :control (keyboard-modifiers .tkw))) +(define-symbol-macro .alt-key-p (find :alt (keyboard-modifiers .tkw))) (defmethod make-tk-instance ((self window)) (setf (gethash (^path) (dictionary .tkw)) self)) --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/11/04 20:53:08 1.7 +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/11/13 05:28:52 1.8 @@ -83,10 +83,10 @@ (defun style-by-edit-menu () - (mk-row ("Style by Edit Menu") - (mk-label :text "Four score and seven years ago today" - :wraplength 600 - :tkfont (c? (list + (mk-row ("Style by Edit Menu") + (mk-label :text "Four score and seven years ago today" + :wraplength 600 + :tkfont (c? (list (selection (fm^ :app-font-face)) (selection (fm^ :app-font-size)) (if (fm^v :app-font-italic) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/11/04 20:53:08 1.18 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/11/13 05:28:52 1.19 @@ -213,7 +213,7 @@ :tk-variable (c? (down$ (path (upper self selector)))) :on-command (lambda (self) (declare (ignore key args)) - (trc nil "menu radio button command firing" self (^value) (upper self selector)) + (trc "menu radio button command firing" self (^value) (upper self selector)) (setf (selection (upper self selector)) (^value))))) (defmodel menu-radio-group (selector family) --- /project/cells/cvsroot/Celtk/run.lisp 2006/10/28 18:21:52 1.22 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/11/13 05:28:52 1.23 @@ -25,6 +25,8 @@ (eval-now! (export '(tk-scaling run-window test-window))) + + (defun run-window (root-class &optional (resetp t) &rest window-initargs) (declare (ignorable root-class)) (setf *tkw* nil) @@ -37,7 +39,16 @@ (tk-app-init *tki*) (tk-togl-init *tki*) (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <> -data $op}") - + (tk-format-now "package require snack") + (tk-format-now "snack::sound s") +;;; (tk-format-now (conc$ "snack::sound s -load " +;;; (snackify-pathname (make-pathname :directory '(:absolute "sounds") +;;; :name "ahem_x" :type "wav") +;;; #+vs (car (directory (make-pathname :directory '(:absolute "sounds"))))))) +;;; (tk-format-now "s play -blocking yes") +;;; (sleep 2) +;;; (tk-format-now "s play") + (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 @@ -65,8 +76,10 @@ ; (tk-format-now "bind . {do-key-down %W %K}") (tk-format-now "bind . {do-key-up %W %K}") - - (tcl-do-one-event-loop)) + (bwhen (ifn (start-up-fn *tkw*)) + (funcall ifn *tkw*)) + (tcl-do-one-event-loop) + ) @@ -93,15 +106,27 @@ (defmethod widget-event-handle ((self window) xe) (let ((*tkw* self)) - (TRC nil "main window event" self *tkw* (xevent-type xe)) + (unless (find (xevent-type xe) '(:MotionNotify)) + (TRC nil "main window event" self *tkw* (xevent-type xe))) (flet ((give-to-window () (bwhen (eh (event-handler *tkw*)) (funcall eh *tkw* xe)))) (case (xevent-type xe) + ((:focusin :focusout) (setf (^focus-state) (xevent-type xe))) ((:MotionNotify :buttonpress) #+shhh (call-dump-event client-data xe)) + (:configurenotify + (setf (^width) (ekx new-width!!! parse-integer (tk-eval "winfo width ."))) + (with-cc :height + (setf (^height) (parse-integer (tk-eval "winfo height .")))) + ) + + (:visibilitynotify + (mathx::a1-snack-off :startup "" 0.8)) (:destroyNotify + (mathx::a1-snack-off :quit "-blocking yes" 0.5) + (let ((*windows-destroyed* (cons *tkw* *windows-destroyed*))) (ensure-destruction *tkw*)))