From ktilton at common-lisp.net Mon Oct 2 02:38:32 2006 From: ktilton at common-lisp.net (ktilton) Date: Sun, 1 Oct 2006 22:38:32 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20061002023832.35D5C47014@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv23239 Modified Files: cell-types.lisp cells-manifesto.txt cells.lisp constructors.lisp defmodel.lisp fm-utilities.lisp integrity.lisp md-slot-value.lisp model-object.lisp propagate.lisp Log Message: Hope I have not broken things, but consider this a warning: I may have. --- /project/cells/cvsroot/cells/cell-types.lisp 2006/07/25 10:51:48 1.17 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/10/02 02:38:31 1.18 @@ -25,12 +25,13 @@ inputp ;; t for old c-variable class synaptic - changed (caller-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify callers FIFO (state :nascent :type symbol) ;; :nascent, :awake, :optimized-away (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :valid} (pulse 0 :type fixnum) + (pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP + lazy debug md-info) @@ -46,9 +47,8 @@ (fifo-delete (c-caller-store used) caller)) (defmethod trcp ((c cell)) - #+not (and ;; (typep (c-model c) 'index) - (find (c-slot-name c) '(celtk::state mathx::problem)))) - + (and #+not(typep (c-model c) 'index) + (find (c-slot-name c) '(mathx::line-breaks mathx::phrases)))) ; --- ephemerality -------------------------------------------------- ; @@ -86,16 +86,12 @@ (defstruct (c-ruled (:include cell) (:conc-name cr-)) - lazy (code nil :type list) ;; /// feature this out on production build rule) (defun c-optimized-away-p (c) (eql :optimized-away (c-state c))) -(defmethod c-lazy ((c c-ruled)) (cr-lazy c)) -(defmethod c-lazy (c) (declare (ignore c)) nil) - ;---------------------------- (defmethod trcp-slot (self slot-name) --- /project/cells/cvsroot/cells/cells-manifesto.txt 2006/06/29 09:54:06 1.8 +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2006/10/02 02:38:31 1.9 @@ -13,7 +13,7 @@ he had to propagate that change to other cells by first remembering which other ones included the changed cell in their computation. Then he had to do the calculations for those, erase, enter... -and then repeating that process to propagate those changes in a +and then repeat that process to propagate those changes in a cascade across the paper. VisiCalc let my father take the formula he had in mind and @@ -61,7 +61,7 @@ way around it, and thus his prediction that a software silver bullet was in principle impossible. -Which brings us to Cells. See also [axiom] Phillip Eby's developiong axiomatic +Which brings us to Cells. See also [axiom] Phillip Eby's developing axiomatic definition he is developing in support of Ryan Forseth's SoC project. DEFMODEL and Slot types @@ -236,8 +236,8 @@ Let's return for a moment to VisiCalc and its descendants. In even the most complex financial spreadsheet model, no one cell rule accesses more than a relatively few other spreadsheet cells (counting a row or column range as one reference). Yet the complex model emerges. All the work of tracking dependencies -is handled by the spreadsheet software, which require no special declaration by the modeller. They simply -writes the Cell rule. In writing the rule, they are concerned only with the derivation of one datapoint from +is handled by the spreadsheet software, which requires no special declaration by the modeller. They simply +write the Cell rule. In writing the rule, they are concerned only with the derivation of one datapoint from a population of other datapoints. No effort goes into arranging for the rule to get run at the right time, and certainly no energy is spent worrying about what other cells might be using the authored cell. That cell has certain semantics -- "account balance", perhaps -- and the modeller need only worry about writing @@ -251,8 +251,8 @@ Model Building -------------- -Everything above could describe one instance of one class defined by DEFMODEL. Of course, we want multiples -of both. In brief: +Everything above could describe one instance of one class defined by DEFMODEL. A real application has +multiple instances of multiple classes. So... -- cells can depend on other cells from any other instance. Since a rule gets passed only "self", Cell users need something like the Family class included with the Cells package effectively to turn a collection of @@ -312,6 +312,7 @@ The dataflow paradigm: http://en.wikipedia.org/wiki/Dataflow Reactive programming: http://www.haskell.org/yampa/AFPLectureNotes.pdf Frame-based programming + Definitive-programming Commentary ---------- --- /project/cells/cvsroot/cells/cells.lisp 2006/08/21 04:29:30 1.16 +++ /project/cells/cvsroot/cells/cells.lisp 2006/10/02 02:38:31 1.17 @@ -25,7 +25,6 @@ (defparameter *causation* nil) (defparameter *data-pulse-id* 0) -(defparameter *data-pulses* nil) (defparameter *c-debug* nil) (defparameter *defer-changes* nil) @@ -33,12 +32,12 @@ (defparameter *client-queue-handler* nil) (defparameter *unfinished-business* nil) -(defun cells-reset (&optional client-queue-handler) +(defun cells-reset (&optional client-queue-handler &key debug) (utils-kt-reset) (setf + *c-debug* debug *c-prop-depth* 0 *data-pulse-id* 0 - *data-pulses* nil *defer-changes* nil ;; should not be necessary, but cannot be wrong *client-queue-handler* client-queue-handler *within-integrity* nil --- /project/cells/cvsroot/cells/constructors.lisp 2006/07/06 22:10:01 1.8 +++ /project/cells/cvsroot/cells/constructors.lisp 2006/10/02 02:38:31 1.9 @@ -48,11 +48,19 @@ (defmacro c?n (&body body) `(make-c-dependent - :code nil ;; `(without-c-dependency ,@,body) + :code '(without-c-dependency , at body) :inputp t :value-state :unevaluated :rule (c-lambda (without-c-dependency , at body)))) +(export! c?once) +(defmacro c?once (&body body) + `(make-c-dependent + :code '(without-c-dependency , at body) + :inputp nil + :value-state :unevaluated + :rule (c-lambda (without-c-dependency , at body)))) + (defmacro c?dbg (&body body) `(make-c-dependent :code ',body --- /project/cells/cvsroot/cells/defmodel.lisp 2006/09/05 18:40:47 1.9 +++ /project/cells/cvsroot/cells/defmodel.lisp 2006/10/02 02:38:31 1.10 @@ -20,6 +20,7 @@ (defmacro defmodel (class directsupers slotspecs &rest options) ;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object))) + (assert (not (find class directsupers))() "~a cannot be its own superclass" class) `(progn (eval-when (:compile-toplevel :execute :load-toplevel) (setf (get ',class :cell-types) nil)) @@ -34,94 +35,87 @@ &allow-other-keys) slotspec - (declare (ignorable slotargs)) + (declare (ignorable slotargs owning)) (list (when cell (let* ((reader-fn (or reader accessor)) - (deriver-fn (intern$ "^" (symbol-name reader-fn))) - ) - ; - ; may as well do this here... - ; - ;;(trc nil "slot, deriverfn would be" slotname deriverfn) + (deriver-fn (intern$ "^" (symbol-name reader-fn)))) `(eval-when (:compile-toplevel :execute :load-toplevel) - (setf (md-slot-cell-type ',class ',slotname) ,cell) (unless (macro-function ',deriver-fn) (defmacro ,deriver-fn () - `(,',reader-fn self)))))) - (when owning - `(eval-when (:compile-toplevel :execute :load-toplevel) - (setf (md-slot-owning ',class ',slotname) ,owning))))))) - - ; - ; ------- defclass --------------- (^slot-value ,model ',',slotname) - ; - - (progn - (defclass ,class ,(or directsupers '(model-object));; now we can def the class - ,(mapcar (lambda (s) - (list* (car s) - (let ((ias (cdr s))) - ;; We handle accessor below - (when (getf ias :cell t) - (remf ias :reader) - (remf ias :writer) - (remf ias :accessor)) - (remf ias :cell) - (remf ias :owning) - (remf ias :unchanged-if) - ias))) (mapcar #'copy-list slotspecs)) - (:documentation - ,@(or (cdr (find :documentation options :key #'car)) - '("chya"))) - (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this - ,@(cdr (find :default-initargs options :key #'car))) - (:metaclass ,(or (cadr (find :metaclass options :key #'car)) - 'standard-class))) - - (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key) - (declare (ignore slot-names iargs)) - ,(when (and directsupers (not (member 'model-object directsupers))) - `(unless (typep self 'model-object) - (error "If no superclass of ~a inherits directly + `(,',reader-fn self)))))))))) + + ; + ; ------- defclass --------------- (^slot-value ,model ',',slotname) + ; + + (progn + (defclass ,class ,(or directsupers '(model-object));; now we can def the class + ,(mapcar (lambda (s) + (list* (car s) + (let ((ias (cdr s))) + ;; We handle accessor below + (when (getf ias :cell t) + (remf ias :reader) + (remf ias :writer) + (remf ias :accessor)) + (remf ias :cell) + (remf ias :owning) + (remf ias :unchanged-if) + ias))) (mapcar #'copy-list slotspecs)) + (:documentation + ,@(or (cdr (find :documentation options :key #'car)) + '("chya"))) + (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this + ,@(cdr (find :default-initargs options :key #'car))) + (:metaclass ,(or (cadr (find :metaclass options :key #'car)) + 'standard-class))) + + (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key) + (declare (ignore slot-names iargs)) + ,(when (and directsupers (not (member 'model-object directsupers))) + `(unless (typep self 'model-object) + (error "If no superclass of ~a inherits directly or indirectly from model-object, model-object must be included as a direct super-class in the defmodel form for ~a" ',class ',class)))) - ; - ; slot accessors once class is defined... - ; - ,@(mapcar (lambda (slotspec) - (destructuring-bind - (slotname &rest slotargs - &key (cell t) unchanged-if (accessor slotname) reader writer type - &allow-other-keys) - slotspec - - (declare (ignorable slotargs)) - (when cell - (let* ((reader-fn (or reader accessor)) - (writer-fn (or writer accessor)) - ) - (setf (md-slot-cell-type class slotname) cell) - - `(progn - ,(when reader-fn - `(defmethod ,reader-fn ((self ,class)) - (md-slot-value self ',slotname))) - - ,(when writer-fn - `(defmethod (setf ,writer-fn) (new-value (self ,class)) - (setf (md-slot-value self ',slotname) - ,(if type - `(coerce new-value ',type) - 'new-value)))) + ; + ; slot accessors once class is defined... + ; + ,@(mapcar (lambda (slotspec) + (destructuring-bind + (slotname &rest slotargs + &key (cell t) owning unchanged-if (accessor slotname) reader writer type + &allow-other-keys) + slotspec + + (declare (ignorable slotargs)) + (when cell + (let* ((reader-fn (or reader accessor)) + (writer-fn (or writer accessor)) + ) + `(progn + (setf (md-slot-cell-type ',class ',slotname) ,cell) - ,(when unchanged-if - `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)) - ) - )) - )) - slotspecs) - (find-class ',class)))) + ,(when owning + `(setf (md-slot-owning ',class ',slotname) ,owning)) + ,(when reader-fn + `(defmethod ,reader-fn ((self ,class)) + (md-slot-value self ',slotname))) + + ,(when writer-fn + `(defmethod (setf ,writer-fn) (new-value (self ,class)) + (setf (md-slot-value self ',slotname) + ,(if type + `(coerce new-value ',type) + 'new-value)))) + + ,(when unchanged-if + `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)) + ) + )) + )) + slotspecs) + (find-class ',class)))) (defun defmd-canonicalize-slot (slotname &key --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/08/31 17:35:28 1.9 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/10/02 02:38:31 1.10 @@ -118,9 +118,9 @@ max)) -(defun fm-traverse (family applied-fn &key skip-node skip-tree global-search opaque) +(defun fm-traverse (family applied-fn &key skip-node skip-tree global-search opaque with-dependency) ;;(when *fmdbg* (trc "fm-traverse" family skipTree skipNode global-search)) - (without-c-dependency + (when family (labels ((tv-family (fm) (etypecase fm @@ -134,13 +134,18 @@ (tv-family kid)) ;(tv-family (mdValue fm)) ))))))) - (tv-family family) - (when global-search - (fm-traverse (fm-parent family) applied-fn - :global-search t - :skip-tree family - :skip-node skip-node)))) - nil)) + (flet ((tv () + (tv-family family) + (when global-search + (fm-traverse (fm-parent family) applied-fn + :global-search t + :skip-tree family + :skip-node skip-node + :with-dependency t)))) ;; t actually just defaults to outermost call + (if with-dependency + (tv) + (without-c-dependency (tv)))))) + (values)) (defun fm-ordered-p (n1 n2 &aux (top (fm-ascendant-common n1 n2))) (assert top) --- /project/cells/cvsroot/cells/integrity.lisp 2006/07/24 05:03:08 1.12 +++ /project/cells/cvsroot/cells/integrity.lisp 2006/10/02 02:38:31 1.13 @@ -30,6 +30,12 @@ "Invalid second value to with-integrity: ~a" opcode)) `(call-with-integrity ,opcode ,defer-info (lambda () , at body))) +(export! with-c-change) + +(defmacro with-c-change (id &body body) + `(with-integrity (:change ,id) + , at body)) + (defun integrity-managed-p () *within-integrity*) @@ -53,23 +59,6 @@ (funcall action) (finish-business))))) -(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-with-integrity-bubble ,dbg-info (lambda () , at body))) - -(defun call-with-integrity-bubble (dbg-info action) - (declare (ignorable dbg-info)) - (let ((*within-integrity* nil) - *unfinished-business* - *defer-changes* - *call-stack* - (*data-pulse-id* 0)) - (funcall action))) - (defun ufb-queue (opcode) (assert (find opcode *ufb-opcodes*)) (cdr (assoc opcode *unfinished-business*))) @@ -115,9 +104,13 @@ ; we do not go back to check for a need to :tell-dependents because (a) the original propagation ; and processing of the :tell-dependents queue is a full propagation; no rule can ask for a cell that ; then decides it needs to recompute and possibly propagate; and (b) the only rules forced awake during - ; awakening need that precisely because no one asked for their values, so their can be no dependents + ; awakening need that precisely because no one asked for their values, so there can be no dependents ; to "tell". I think. :) So... ; + (when (fifo-peek (ufb-queue :tell-dependents)) + (DOlist (b (fifo-data (ufb-queue :tell-dependents))) + (trc "unhandled :tell-dependents" (car b) (c-callers (car b)))) + (break "ufb")) (assert (null (fifo-peek (ufb-queue :tell-dependents)))) ;--- process client queue ------------------------------ --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/08/21 04:29:30 1.27 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/10/02 02:38:31 1.28 @@ -55,8 +55,10 @@ (declare (ignorable debug-id caller)) (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))) (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 ;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete @@ -64,17 +66,27 @@ ((c-inputp c)(trc nil "c-inputp" c)) ;; always current (for now; see above) ((or (not (c-validp c)) - (some (lambda (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 and newer !!!!!!" c used) - t)) - (cd-useds c))) - (trc nil "ensuring current calc-set of" (c-slot-name c)) + ;; + ;; new for 2006-09-21: a cell ended up checking slots of a dead instance, which would have been + ;; refreshed when checked, but was going to be checked last because it was the first used, useds + ;; being simply pushed onto a list as they come up. We may need fancier handling of dead instance/cells + ;; still being encountered by consulting the prior useds list, but checking now in same order as + ;; accessed seems Deeply Correct (and fixed the immediate problem nicely, always a Good Sign). + ;; + (labels ((check-reversed (useds) + (when useds + (or (check-reversed (cdr useds)) + (let ((used (car useds))) + (ensure-value-is-current used :nested c) + (trc nil "comparing pulses (caller, used, used-changed): " c debug-id used (c-pulse-last-changed used)) + (when (> (c-pulse-last-changed used)(c-pulse c)) + (trc nil "used changed and newer !!!!!!" c debug-id used) + t)))))) + (check-reversed (cd-useds c)))) + (trc nil "kicking off calc-set of" (c-slot-name c) :pulse *data-pulse-id*) (calculate-and-set c)) - (t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) ) + (t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) debug-id) (c-pulse-update c :valid-uninfluenced))) (when (c-unboundp c) @@ -157,7 +169,7 @@ ; --- data flow propagation ----------- ; - (setf (c-changed c) t) + (setf (c-pulse-last-changed c) *data-pulse-id*) (without-c-dependency (c-propagate c prior-value t))))))) @@ -178,11 +190,16 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s" slot-name self (slot-value self slot-name))) - (when *defer-changes* + (cond + ((find (c-lazy c) '(:once-asked :always t)) + (md-slot-value-assume c new-value nil)) + + (*defer-changes* (c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c)) - (with-integrity (:change) - (md-slot-value-assume c new-value nil)) + (t + (with-integrity (:change slot-name) + (md-slot-value-assume c new-value nil)))) ;; new-value ;; above line commented out 2006-05-01. It seems to me we want the value assumed by the slot @@ -222,7 +239,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) + (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)) absorbed-value))) --- /project/cells/cvsroot/cells/model-object.lisp 2006/09/05 18:40:47 1.11 +++ /project/cells/cvsroot/cells/model-object.lisp 2006/10/02 02:38:31 1.12 @@ -25,6 +25,7 @@ (defclass model-object () ((.md-state :initform :nascent :accessor md-state) ; [nil | :nascent | :alive | :doomed] + (.awaken-on-init-p :initform nil :initarg :awaken-on-init-p :accessor awaken-on-init-p) ; [nil | :nascent | :alive | :doomed] (.cells :initform nil :accessor cells) (.cells-flushed :initform nil :accessor cells-flushed :documentation "cells supplied but un-whenned or optimized-away") @@ -51,17 +52,22 @@ for sn = (slot-definition-name esd) for sv = (when (slot-boundp self sn) (slot-value self sn)) - ;; do (print (list self sn sv (typep sv 'cell))) + ;; do (print (list (type-of self) sn sv (typep sv 'cell))) when (typep sv 'cell) do (if (md-slot-cell-type (type-of self) sn) (md-install-cell self sn sv) (when *c-debug* - (trc "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv self sn)))) + (break "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv sn (type-of self))))) ; ; queue up for awakening ; - (with-integrity (:awaken self) - (md-awaken self)))) + (if (awaken-on-init-p self) + (md-awaken self) + (with-integrity (:awaken self) + (md-awaken self))) + )) + + (defun md-install-cell (self sn c &aux (c-isa-cell (typep c 'cell))) ; @@ -162,14 +168,18 @@ (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))) + (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 (setf (md-slot-cell-type class-name slot-name) (cdr entry))))))) + (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 - (setf (cdr entry) new-type) + (progn + (setf (cdr entry) new-type) + (loop for c in (mop: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))))) (defun md-slot-owning (class-name slot-name) @@ -182,11 +192,12 @@ (defun (setf md-slot-owning) (value class-name slot-name) (let ((entry (assoc slot-name (get class-name :ownings)))) (if entry - (setf (cdr entry) value) + (progn + (setf (cdr entry) value) + (loop for c in (mop: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))))) - - (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)) --- /project/cells/cvsroot/cells/propagate.lisp 2006/09/05 18:40:47 1.21 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/10/02 02:38:31 1.22 @@ -46,10 +46,10 @@ (defun c-pulse-update (c key) (declare (ignorable key)) - (trc nil "c-pulse-update updating" *data-pulse-id* c key) - (assert (>= *data-pulse-id* (c-pulse c))) - (setf (c-changed c) nil - (c-pulse c) *data-pulse-id*)) + (trc nil "c-pulse-update updating" *data-pulse-id* c key :prior-pulse (c-pulse c)) + (assert (>= *data-pulse-id* (c-pulse c)) () + "Current DP ~a not GE pulse ~a of cell ~a" *data-pulse-id* (c-pulse c) c) + (setf (c-pulse c) *data-pulse-id*)) ;--------------- propagate ---------------------------- @@ -90,19 +90,19 @@ ; expected to have side-effects, so we want to propagate fully and be sure no rule ; wants a rollback before starting with the side effects. ; - (c-propagate-to-callers c) + (unless nil #+not (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this + (c-propagate-to-callers c)) (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))) - (bwhen (lost (set-difference prior-value (c-value c))) - (trc "bingo!!!!! lost nailing" lost) - (break "go") - (typecase lost - (atom (not-to-be lost)) - (cons (mapcar 'not-to-be lost))))) + (flet ((listify (x) (if (listp x) x (list x)))) + (bwhen (lost (set-difference (listify prior-value) (listify (c-value c)))) + (trc "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 @@ -113,8 +113,7 @@ ; would this be bad for persistent CLOS, in which a DB would think there was still a link ; between two records until the value actually got cleared? ; - (ephemeral-reset c) - )) + (ephemeral-reset c))) ; --- slot change ----------------------------------------------------------- @@ -177,7 +176,7 @@ (let ((*causation* causation)) (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)) + (unless (member (c-lazy caller) '(t :always :once-asked)) (trc nil "propagating to caller is caller:" caller) (ensure-value-is-current caller :prop-from c)))))))) From ktilton at common-lisp.net Mon Oct 2 02:38:32 2006 From: ktilton at common-lisp.net (ktilton) Date: Sun, 1 Oct 2006 22:38:32 -0400 (EDT) Subject: [cells-cvs] CVS cells/gui-geometry Message-ID: <20061002023832.7BEC84B002@common-lisp.net> Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv23239/gui-geometry Modified Files: gui-geometry.lpr Log Message: Hope I have not broken things, but consider this a warning: I may have. --- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/08/21 04:29:31 1.4 +++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/10/02 02:38:32 1.5 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 17, 2006 12:24)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Mon Oct 2 02:38:32 2006 From: ktilton at common-lisp.net (ktilton) Date: Sun, 1 Oct 2006 22:38:32 -0400 (EDT) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20061002023832.C1D184B002@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv23239/utils-kt Modified Files: debug.lisp flow-control.lisp Log Message: Hope I have not broken things, but consider this a warning: I may have. --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/09/05 18:40:48 1.12 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/10/02 02:38:32 1.13 @@ -30,7 +30,7 @@ (setf *count* nil *stop* nil *dbg* nil) - (print "----------UTILSRESET----------------------------------")) + (print "----------UTILSRESET----------------------------------")) --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/09/05 18:40:50 1.6 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/10/02 02:38:32 1.7 @@ -60,7 +60,7 @@ (list-flatten! (copy-tree tree))) (defun packed-flat! (&rest u-nameit) - (delete nil (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 Oct 2 02:56:01 2006 From: ktilton at common-lisp.net (ktilton) Date: Sun, 1 Oct 2006 22:56:01 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20061002025601.922E27D0BB@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv27482 Modified Files: Celtk.lisp composites.lisp run.lisp togl.lisp widget.lisp Log Message: --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/09/05 18:43:22 1.35 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/10/02 02:56:01 1.36 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.35 2006/09/05 18:43:22 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.36 2006/10/02 02:56:01 ktilton Exp $ (defpackage :celtk (:nicknames "CTK") @@ -103,31 +103,6 @@ (trc nil "!!! --- tk-user-queue-handler dispatching" defer-info) (funcall task))) -(defun replace-char (txt char with) - (let ((pos (search char txt))) - (loop - while pos - do - (progn - ;;(dbg "txt: ~a -> " txt) - (setf txt (concatenate 'string (subseq txt 0 pos) with (subseq txt (1+ pos)))) - ;;(dbg " ~a~&" txt) - (setf pos (search char txt :start2 (+ pos (length with))))))) - txt) - -(defun tkescape (txt) - (setf txt (format nil "~a" txt)) - (replace-char - (replace-char - (replace-char - (replace-char - (replace-char - txt "\\" "\\\\") - "$" "\\$") - "[" "\\[") - "]" "\\]") - "\"" "\\\"")) - (defun tk-format-now (fmt$ &rest fmt-args) (unless (find *tkw* *windows-destroyed*) (let* ((*print-circle* nil) --- /project/cells/cvsroot/Celtk/composites.lisp 2006/09/29 16:08:31 1.18 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/10/02 02:56:01 1.19 @@ -32,7 +32,7 @@ ;;; --- decoration ------------------------------------------- (defmd decoration-mixin () - (decoration (c-in :normal))) + (decoration (c-in nil))) ;;; --- toplevel --------------------------------------------- @@ -113,6 +113,9 @@ on-key-down on-key-up) +(defmethod make-tk-instance ((self window)) + (setf (gethash (^path) (dictionary .tkw)) self)) + (defun screen-width () (let ((*tkw* *tkw*)) (tk-format-now "winfo screenwidth ."))) @@ -133,6 +136,7 @@ (tk-format '(:pre-make-tk self) "wm overrideredirect . yes") ) + (defmethod do-on-key-down :before (self &rest args &aux (keysym (car args))) (trc nil "ctk::do-on-key-down window" keysym (keyboard-modifiers .tkw)) (bwhen (mod (keysym-to-modifier keysym)) @@ -148,6 +152,7 @@ ;;; Helper function that actually executes decoration change (defun %%do-decoration (widget decoration) + (break "hunh?") (let ((path (path widget))) (ecase decoration (:none (progn --- /project/cells/cvsroot/Celtk/run.lisp 2006/09/05 18:43:22 1.20 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/10/02 02:56:01 1.21 @@ -18,6 +18,8 @@ (in-package :Celtk) + + ;;; --- running a Celtk (window class, actually) -------------------------------------- (eval-now! @@ -66,6 +68,8 @@ (tcl-do-one-event-loop)) + + (defun ensure-destruction (w) (TRC nil "ensure-destruction entry" W) (unless (find w *windows-being-destroyed*) --- /project/cells/cvsroot/Celtk/togl.lisp 2006/09/05 18:43:22 1.20 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/10/02 02:56:01 1.21 @@ -90,8 +90,12 @@ (togl-timer-func (callback togl-timer)) ;; probably want to make this optional ) +(export! togl-ptr-set ^togl-ptr-set) + (deftk togl (widget) - ((togl-ptr :cell nil :initform nil :initarg :togl-ptr :accessor togl-ptr) + ((togl-ptr :cell nil :initform nil :initarg :togl-ptr :accessor togl-ptr) + (togl-ptr-set :initform (c-in nil) :initarg :togl-ptr-set :accessor togl-ptr-set + :documentation "very complicated, don't ask (togl-ptr cannot wait on ufb processing)") (cb-create :initform nil :initarg :cb-create :reader cb-create) (cb-display :initform nil :initarg :cb-display :reader cb-display) (cb-reshape :initform nil :initarg :cb-reshape :reader cb-reshape) @@ -150,6 +154,11 @@ :id (gentemp "TOGL") :ident (c? (^path)))) +(export! togl-redisp) +(defun togl-redisp (togl) + (when (togl-ptr togl) + (togl-post-redisplay (togl-ptr togl)))) + (defmacro with-togl ((togl-form width-var height-var) &body body &aux (togl-ptr (gensym))) `(let* ((,togl-ptr (togl-ptr ,togl-form)) (*tki* (togl-interp ,togl-ptr)) @@ -184,10 +193,11 @@ (defmethod ,(intern uc$) ((self togl)))))) (def-togl-callback create () - (trc "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr ) + (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) - (setf (togl-ptr self) togl-ptr) + (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)) (def-togl-callback display ()) @@ -198,7 +208,6 @@ (defmethod make-tk-instance ((self togl)) (with-integrity (:client `(:make-tk ,self)) (setf (gethash (^path) (dictionary .tkw)) self) + (trc "making togl!!!!!!!!!!!!" (path self)(tk-configurations self)) (tk-format-now "togl ~a ~{~(~a~) ~a~^ ~}" (path self)(tk-configurations self)))) - ;; this leads to "togl [- Update of /project/cells/cvsroot/Celtk/gears In directory clnet:/tmp/cvs-serv27482/gears Modified Files: gears.lpr Log Message: --- /project/cells/cvsroot/Celtk/gears/gears.lpr 2006/05/26 17:50:36 1.1 +++ /project/cells/cvsroot/Celtk/gears/gears.lpr 2006/10/02 02:56:01 1.2 @@ -1,11 +1,12 @@ -;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :GEARS) (define-project :name :gears - :modules (list (make-instance 'module :name "gears.lisp")) + :modules (list (make-instance 'module :name "gears.lisp") + (make-instance 'module :name "nehe-02")) :projects (list (make-instance 'project-module :name "..\\CELTK") (make-instance 'project-module :name "C:\\1-devtools\\cl-opengl\\glu")) @@ -77,7 +78,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'gears::gears + :on-initialization 'gears::nehe-02 :on-restart 'do-default-restart) ;; End of Project Definition From ktilton at common-lisp.net Mon Oct 2 20:55:00 2006 From: ktilton at common-lisp.net (ktilton) Date: Mon, 2 Oct 2006 16:55:00 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20061002205500.4FD347021E@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv16659 Modified Files: cell-types.lisp link.lisp Log Message: lose mathx package refs --- /project/cells/cvsroot/cells/cell-types.lisp 2006/10/02 02:38:31 1.18 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/10/02 20:55:00 1.19 @@ -46,9 +46,9 @@ (defun caller-drop (used caller) (fifo-delete (c-caller-store used) caller)) -(defmethod trcp ((c cell)) - (and #+not(typep (c-model c) 'index) - (find (c-slot-name c) '(mathx::line-breaks mathx::phrases)))) +;;;(defmethod trcp ((c cell)) +;;; (and (typep (c-model c) 'index) +;;; (find (c-slot-name c) '(mathx::line-breaks mathx::phrases)))) ; --- ephemerality -------------------------------------------------- ; --- /project/cells/cvsroot/cells/link.lisp 2006/08/21 04:29:30 1.17 +++ /project/cells/cvsroot/cells/link.lisp 2006/10/02 20:55:00 1.18 @@ -58,8 +58,8 @@ (defun c-unlink-unused (c &aux (usage (cd-usage c)) (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)))) + (dbg nil)) ;; #+not (and (typep (c-model c) 'mathx::mx-solver-stack) + ;;(eq (c-slot-name c) '.kids)))) (declare (ignorable usage-size)) (when (cd-useds c) (let (rev-pos) From ktilton at common-lisp.net Fri Oct 6 08:01:10 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 6 Oct 2006 04:01:10 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20061006080110.A3DC52F047@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv7005 Modified Files: trc-eko.lisp Log Message: --- /project/cells/cvsroot/cells/trc-eko.lisp 2006/09/03 13:41:09 1.2 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2006/10/06 08:01:10 1.3 @@ -46,6 +46,17 @@ (count-it :trcfailed))) (count-it :tgtnileval))))))) +(export! trcx) + +(defmacro trcx (tgt-form &rest os) + (if (eql tgt-form 'nil) + '(progn) + `(without-c-dependency + (call-trc t ,(format nil "TX> ~(~a~)" tgt-form) + ,@(loop for obj in os + nconcing (list (format nil "~a:" obj) obj)))))) + + (defparameter *last-trc* (get-internal-real-time)) (defun call-trc (stream s &rest os) @@ -58,7 +69,7 @@ (format stream "~a" s) (let (pkwp) (dolist (o os) - (format stream (if pkwp " ~(~s~)" " __ ~(~s~)") o) + (format stream (if pkwp " ~(~s~)" " ~(~s~)") o) ;; save, used to insert divider, trcx dont like (setf pkwp (keywordp o)))) (force-output stream) (values)) From ktilton at common-lisp.net Wed Oct 11 22:16:22 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 11 Oct 2006 18:16:22 -0400 (EDT) Subject: [cells-cvs] CVS cells/gui-geometry Message-ID: <20061011221622.D16921A008@common-lisp.net> Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv31873/gui-geometry Modified Files: geo-family.lisp geometer.lisp Log Message: --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/07/06 22:10:02 1.6 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/10/11 22:16:22 1.7 @@ -38,8 +38,9 @@ (pr lk) 0))))) :lb (c? (+ (- (^outset)) (ecase (orientation self) - (:vertical (bif (lk (last1 (^kids))) - (pb lk) 0)) + (:vertical (loop for k in (^kids) + unless (collapsed k) + maximizing (pb k))) (:horizontal (downs (loop for k in (^kids) maximizing (l-height k))))))) :kid-slots (lambda (self) --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/08/21 04:29:31 1.8 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/10/11 22:16:22 1.9 @@ -224,6 +224,8 @@ ;---------------------------------- +(export! geo-kid-wrap) + (defun geo-kid-wrap (self bound) (funcall (ecase bound ((pl pb) '-)((pr pt) '+)) (funcall (ecase bound From ktilton at common-lisp.net Wed Oct 11 22:16:22 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 11 Oct 2006 18:16:22 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20061011221622.B352D1A006@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv31873 Modified Files: cells-manifesto.txt fm-utilities.lisp propagate.lisp Log Message: --- /project/cells/cvsroot/cells/cells-manifesto.txt 2006/10/02 02:38:31 1.9 +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2006/10/11 22:16:20 1.10 @@ -267,8 +267,8 @@ -- kid-slotting: used almost exclusively so far for orderly GUI layout, a parent must be able to specify rules for specific slots of kids. Example: a "stack" class wants to provide rules for child geometry specifying left, right, or centered alignment and vertical stacking (with optional spacing) one below -the other. The idea is that we want to other child instances without worrying about how they will -be arranged in some container. +the other. The idea is that we want to author classes of what might be GUI subcomponents without worrying +about how they will be arranged in some container. -- finalization: when an instance appears in the "old kids" but not in the "new kids", a Cells engine may need to arrange for all Cells to "unsubscribe" from their dependents. Cells takes care of that if @@ -367,11 +367,11 @@ deferred until all computed cells are up-to-date with the current state of the universe." -_______________ -Uncommentary :) +_____________ +Uncommentary -- Peter Seibel, comp.lang.lisp: -"I couldn't find anything that explained what it was and why I should care." +"I couldn't find anything that explained what [Cells] was and why I should care." -- Alan Crowe, comp.lang.lisp: "Further confession: I'm bluffing. I've grasped that Cells is --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/10/02 02:38:31 1.10 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/10/11 22:16:22 1.11 @@ -44,6 +44,11 @@ (defmacro upper (self &optional (type t)) `(container-typed ,self ',type)) +(export! u^) + +(defmacro u^ (type) + `(upper self ,type)) + (defmethod container (self) (fm-parent self)) (defmethod container-typed ((self model-object) type) --- /project/cells/cvsroot/cells/propagate.lisp 2006/10/02 02:38:31 1.22 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/10/11 22:16:22 1.23 @@ -101,7 +101,7 @@ (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 "prop nailing owned" c (c-value c) prior-value lost) + (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 From ktilton at common-lisp.net Wed Oct 11 22:16:23 2006 From: ktilton at common-lisp.net (ktilton) Date: Wed, 11 Oct 2006 18:16:23 -0400 (EDT) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20061011221623.27CF01F000@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv31873/utils-kt Modified Files: detritus.lisp Log Message: --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/09/05 18:40:48 1.10 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/10/11 22:16:22 1.11 @@ -46,11 +46,23 @@ (defun xor (c1 c2) (if c1 (not c2) c2)) -(export! push-end) +(export! push-end collect collect-if) (defmacro push-end (item place ) `(setf ,place (nconc ,place (list ,item)))) +(defun collect (x list &key (key 'identity) (test 'eql)) + (loop for i in list + when (funcall test x (funcall key i)) + collect i)) + +(defun collect-if (test list) + (loop for i in list + when (funcall test i) + collect i)) + + + ;;; --- FIFO Queue ----------------------------- (defun make-fifo-queue (&rest init-data) From ktilton at common-lisp.net Fri Oct 13 05:56:39 2006 From: ktilton at common-lisp.net (ktilton) Date: Fri, 13 Oct 2006 01:56:39 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20061013055639.1DF494E002@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv1506 Modified Files: fm-utilities.lisp Log Message: --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/10/11 22:16:22 1.11 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/10/13 05:56:38 1.12 @@ -401,6 +401,11 @@ :global-search t :test ,test)) +(export! fmv) + +(defmacro fmv (name) + `(md-value (fm-other ,name))) + (defmacro fm-otherx (md-name &key (starting 'self) skip-tree) (if (eql starting 'self) `(or (fm-find-one ,starting ,(if (consp md-name) From ktilton at common-lisp.net Tue Oct 17 21:28:39 2006 From: ktilton at common-lisp.net (ktilton) Date: Tue, 17 Oct 2006 17:28:39 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20061017212839.CA7506912C@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv6035 Modified Files: cell-types.lisp cells.lpr constructors.lisp defpackage.lisp integrity.lisp link.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp propagate.lisp trc-eko.lisp Log Message: Mostly someone screwing with file creation dates, but also a profound change to handling of cell currency in the face of model quiescence. See list (or code remarks re :uncurrent) for deets. --- /project/cells/cvsroot/cells/cell-types.lisp 2006/10/02 20:55:00 1.19 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/10/17 21:28:39 1.20 @@ -28,7 +28,13 @@ (caller-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify callers FIFO (state :nascent :type symbol) ;; :nascent, :awake, :optimized-away - (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :valid} + (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :uncurrent | :valid} + ; uncurrent (aka dirty) new for 06-10-15. we need this so + ; c-quiesce can force a caller to update when asked + ; in case the owner of the quiesced cell goes out of existence + ; in a way the caller will not see via any kids dependency. Saw + ; this one coming a long time ago: depending on cell X implies + ; a dependency on the existence of instance owning X (pulse 0 :type fixnum) (pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP lazy --- /project/cells/cvsroot/cells/cells.lpr 2006/08/28 21:44:13 1.21 +++ /project/cells/cvsroot/cells/cells.lpr 2006/10/17 21:28:39 1.22 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cells/cvsroot/cells/constructors.lisp 2006/10/02 02:38:31 1.9 +++ /project/cells/cvsroot/cells/constructors.lisp 2006/10/17 21:28:39 1.10 @@ -83,6 +83,17 @@ :lazy :until-asked :rule (c-lambda , at body))) +(export! c?dbg c_?dbg) + +(defmacro c_?dbg (&body body) + "Lazy until asked, then eagerly propagating" + `(make-c-dependent + :code ',body + :value-state :unevaluated + :lazy :until-asked + :rule (c-lambda , at body) + :debug t)) + (defmacro c?? ((&key (tagp nil) (in nil) (out t))&body body) (let ((result (copy-symbol 'result)) (thetag (gensym))) --- /project/cells/cvsroot/cells/defpackage.lisp 2006/06/20 14:16:44 1.7 +++ /project/cells/cvsroot/cells/defpackage.lisp 2006/10/17 21:28:39 1.8 @@ -42,6 +42,7 @@ #:class-precedence-list #-(and mcl (not openmcl-partial-mop)) #:class-slots #:slot-definition-name + #:class-direct-subclasses ) (:export #:cell #:.md-name #:c-input #:c-in #:c-in8 --- /project/cells/cvsroot/cells/integrity.lisp 2006/10/02 02:38:31 1.13 +++ /project/cells/cvsroot/cells/integrity.lisp 2006/10/17 21:28:39 1.14 @@ -70,6 +70,8 @@ (defun ufb-add (opcode continuation) (assert (find opcode *ufb-opcodes*)) + (when (and *no-tell* (eq opcode :tell-dependents)) + (break "truly queueing tell under no-tell")) (trc nil "ufb-add deferring" opcode (when (eql opcode :client)(car continuation))) (fifo-add (ufb-queue-ensure opcode) continuation)) @@ -81,7 +83,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 @@ -99,7 +101,14 @@ ; during their awakening to be handled along with those enqueued by cells of ; existing model instances. ; - (just-do-it :awaken) ;--- md-awaken new instances --- + (bwhen (uqp (fifo-peek (ufb-queue :tell-dependents))) + (trcx finish-business uqp) + (DOlist (b (fifo-data (ufb-queue :tell-dependents))) + (trc "unhandled :tell-dependents" (car b) (c-callers (car b)))) + (break "unexpected 1> ufb needs to tell dependnents after telling dependents")) + (let ((*no-tell* t)) + (just-do-it :awaken) ;--- md-awaken new instances --- + ) ; ; we do not go back to check for a need to :tell-dependents because (a) the original propagation ; and processing of the :tell-dependents queue is a full propagation; no rule can ask for a cell that @@ -107,10 +116,12 @@ ; awakening need that precisely because no one asked for their values, so there can be no dependents ; to "tell". I think. :) So... ; - (when (fifo-peek (ufb-queue :tell-dependents)) + (bwhen (uqp (fifo-peek (ufb-queue :tell-dependents))) + (trcx finish-business uqp) (DOlist (b (fifo-data (ufb-queue :tell-dependents))) (trc "unhandled :tell-dependents" (car b) (c-callers (car b)))) - (break "ufb")) + (break "unexpected 2> ufb needs to tell dependnents after awakening")) + (assert (null (fifo-peek (ufb-queue :tell-dependents)))) ;--- process client queue ------------------------------ --- /project/cells/cvsroot/cells/link.lisp 2006/10/02 20:55:00 1.18 +++ /project/cells/cvsroot/cells/link.lisp 2006/10/17 21:28:39 1.19 @@ -25,7 +25,7 @@ (defun record-caller (used &aux (caller (car *call-stack*))) (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell (return-from record-caller nil)) - (trc nil "record-caller entry: used=" used :caller caller) + (trc used "record-caller entry: used=" used :caller caller) (multiple-value-bind (used-pos useds-len) (loop with u-pos for known in (cd-useds caller) @@ -37,7 +37,7 @@ finally (return (values (when u-pos (- length u-pos)) length))) (when (null used-pos) - (trc nil "c-link > new caller,used " caller used) + (trc caller "c-link > new caller,used " caller used) (count-it :new-used) (setf used-pos useds-len) (push used (cd-useds caller)) @@ -69,6 +69,7 @@ (zerop (sbit usage rpos))) (progn (count-it :unlink-unused) + (trc c "c-unlink-unused" c :dropping-used (car useds)) (c-unlink-caller (car useds) c) (rplaca useds nil)) (progn --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/10/02 02:38:31 1.28 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/10/17 21:28:39 1.29 @@ -60,10 +60,12 @@ (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 + ((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 ;; - ((c-inputp c)(trc nil "c-inputp" c)) ;; always current (for now; see above) + ((and (c-inputp c) + (c-validp c))) ;; a c?n (ruled-then-input) cell will not be valid at first ((or (not (c-validp c)) ;; --- /project/cells/cvsroot/cells/md-utilities.lisp 2006/09/03 13:41:09 1.8 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2006/10/17 21:28:39 1.9 @@ -56,10 +56,11 @@ (defun c-quiesce (c) (typecase c (cell - (trc nil "c-quiesce unlinking" c) + (trc c "c-quiesce unlinking" c) (c-unlink-from-used c) (when (typep c 'cell) (dolist (caller (c-callers c)) + (setf (c-value-state caller) :uncurrent) (c-unlink-caller c caller))) (trc nil "cell quiesce nulled cell awake" c)))) @@ -70,6 +71,6 @@ (defmacro make-kid (class &rest initargs) `(make-instance ,class - :fm-parent (progn (assert self) self) - , at initargs)) + , at initargs + :fm-parent (progn (assert self) self))) --- /project/cells/cvsroot/cells/model-object.lisp 2006/10/02 02:38:31 1.12 +++ /project/cells/cvsroot/cells/model-object.lisp 2006/10/17 21:28:39 1.13 @@ -178,7 +178,7 @@ (if entry (progn (setf (cdr entry) new-type) - (loop for c in (mop:class-direct-subclasses (find-class class-name)) + (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))))) @@ -194,7 +194,7 @@ (if entry (progn (setf (cdr entry) value) - (loop for c in (mop:class-direct-subclasses (find-class class-name)) + (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))))) --- /project/cells/cvsroot/cells/propagate.lisp 2006/10/11 22:16:22 1.23 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/10/17 21:28:39 1.24 @@ -72,7 +72,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) (when *c-debug* (when (> *c-prop-depth* 250) @@ -168,9 +168,12 @@ ; but B is busy eagerly propagating. "This time" is important because it means ; there is no way one can reliably be sure H will not ask for A ; - (when (c-callers c) - (trc nil "c-propagate-to-callers > queueing" c) - (let ((causation (cons c *causation*))) ;; in case deferred + (when (find-if-not (lambda (caller) + (and (c-lazy caller) ;; slight optimization + (member (c-lazy caller) '(t :always :once-asked)))) + (c-callers c)) + (let ((causation (cons c *causation*)) ;; in case deferred + ) (with-integrity (:tell-dependents c) (assert (null *call-stack*)) (let ((*causation* causation)) --- /project/cells/cvsroot/cells/trc-eko.lisp 2006/10/06 08:01:10 1.3 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2006/10/17 21:28:39 1.4 @@ -126,6 +126,14 @@ (trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) ,result))) +(defmacro ekx (ekx-id &rest body) + (let ((result (gensym))) + `(let ((,result (, at body))) + (trc ,(string-downcase (symbol-name ekx-id)) :=> ,result) + ,result))) + +(export! ekx) + (defmacro eko-if ((&rest trcargs) &rest body) (let ((result (gensym))) `(let ((,result , at body)) From ktilton at common-lisp.net Tue Oct 17 21:28:40 2006 From: ktilton at common-lisp.net (ktilton) Date: Tue, 17 Oct 2006 17:28:40 -0400 (EDT) Subject: [cells-cvs] CVS cells/gui-geometry Message-ID: <20061017212840.9027871035@common-lisp.net> Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv6035/gui-geometry Modified Files: geo-data-structures.lisp geo-family.lisp geometer.lisp Log Message: Mostly someone screwing with file creation dates, but also a profound change to handling of cell currency in the face of model quiescence. See list (or code remarks re :uncurrent) for deets. --- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/08/21 04:29:31 1.6 +++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/10/17 21:28:39 1.7 @@ -258,7 +258,7 @@ (defun nr-offset (r dh dv) ;;; (declare (optimize (speed 3) (safety 0) (debug 0))) - (declare (type fixnum dh dv)) + ;; (declare (type fixnum dh dv)) (incf (r-left r) dh) (incf (r-right r) dh) (incf (r-top r) dv) --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/10/11 22:16:22 1.7 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/10/17 21:28:39 1.8 @@ -53,7 +53,7 @@ (^prior-sib-pb self (spacing .parent))))))) (:horizontal (list (mk-kid-slot (py :if-missing t) - (c? (^py-self-centered (justify .parent)))) + (c? (py-self-centered self (justify .parent)))) (mk-kid-slot (px) (c? (px-maintain-pl (^prior-sib-pr self (spacing .parent))))))))))) @@ -91,7 +91,7 @@ (^prior-sib-pb self (spacing .parent))))))))) (:horizontal (list (mk-kid-slot (py :if-missing t) - (c_? (^py-self-centered (justify .parent)))) + (c_? (py-self-centered self (justify .parent)))) (mk-kid-slot (px) (c_? (px-maintain-pl (^prior-sib-pr self (spacing .parent))))))))))) --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/10/11 22:16:22 1.9 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/10/17 21:28:39 1.10 @@ -137,8 +137,8 @@ (v-xlate outer (fm-parent inner) (- outer-v (py inner))))) -(defmethod g-offset (self &optional (accum-h 0) (accum-v 0)) - (declare (ignorable self)) +(defmethod g-offset (self &optional (accum-h 0) (accum-v 0) within) + (declare (ignorable self within)) (mkv2 accum-h accum-v)) (defun g-offset-h (geo) @@ -336,12 +336,12 @@ (:right (- (inset-lr .parent) (l-width self)))))) ; in use; same idea for pT -(defmacro ^py-self-centered (justify) - `(py-maintain-pt - (ecase ,justify - (:top 0) - (:center (floor (- (inset-height .parent) (l-height self)) -2)) - (:bottom (- (inset-height .parent) (l-height self)))))) +(defun py-self-centered (self justify) + (py-maintain-pt + (ecase justify + (:top 0) + (:center (floor (- (inset-height .parent) (l-height self)) -2)) + (:bottom (- (inset-height .parent) (l-height self)))))) (defmacro ^fill-parent-right (&optional (inset 0)) `(lr-maintain-pr (- (inset-lr .parent) ,inset))) From ktilton at common-lisp.net Tue Oct 17 21:28:42 2006 From: ktilton at common-lisp.net (ktilton) Date: Tue, 17 Oct 2006 17:28:42 -0400 (EDT) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20061017212842.B0B8472083@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv6035/utils-kt Modified Files: utils-kt.asd utils-kt.lpr Log Message: Mostly someone screwing with file creation dates, but also a profound change to handling of cell currency in the face of model quiescence. See list (or code remarks re :uncurrent) for deets. --- /project/cells/cvsroot/cells/utils-kt/utils-kt.asd 2005/05/06 21:05:56 1.1 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.asd 2006/10/17 21:28:40 1.2 @@ -16,11 +16,13 @@ :licence "MIT Style" :description "Kenny's Utilities" :long-description "Low-level utilities used by all of Kenny's projects" + :serial t :components ((:file "defpackage") (:file "debug") - (:file "detritus") (:file "flow-control") - (:file "strings"))) + (:file "detritus") + (:file "strings") + (:file "datetime"))) (defmethod perform ((o load-op) (c (eql (find-system :utils-kt)))) ; (pushnew "CELLS" *modules* :test #'string=) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/09/03 13:41:10 1.18 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/10/17 21:28:40 1.19 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Sat Oct 28 18:20:54 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 28 Oct 2006 14:20:54 -0400 (EDT) Subject: [cells-cvs] CVS cells Message-ID: <20061028182054.213C57208A@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv3409 Modified Files: cell-types.lisp cells.lisp constructors.lisp link.lisp md-slot-value.lisp md-utilities.lisp trc-eko.lisp Log Message: I forget. Some interesting stuff, I think. --- /project/cells/cvsroot/cells/cell-types.lisp 2006/10/17 21:28:39 1.20 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/10/28 18:20:48 1.21 @@ -38,9 +38,14 @@ (pulse 0 :type fixnum) (pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP lazy + (optimize t) debug md-info) +(defmethod trcp :around ((c cell)) + (or (c-debug c) + (call-next-method))) + (defun c-callers (c) "Make it easier to change implementation" (fifo-data (c-caller-store c))) @@ -96,7 +101,7 @@ rule) (defun c-optimized-away-p (c) - (eql :optimized-away (c-state c))) + (eq :optimized-away (c-state c))) ;---------------------------- --- /project/cells/cvsroot/cells/cells.lisp 2006/10/02 02:38:31 1.17 +++ /project/cells/cvsroot/cells/cells.lisp 2006/10/28 18:20:48 1.18 @@ -78,6 +78,8 @@ (defmacro without-c-dependency (&body body) `(let (*call-stack*) , at body)) +(export! .cause) + (define-symbol-macro .cause (car *causation*)) --- /project/cells/cvsroot/cells/constructors.lisp 2006/10/17 21:28:39 1.10 +++ /project/cells/cvsroot/cells/constructors.lisp 2006/10/28 18:20:48 1.11 @@ -53,7 +53,15 @@ :value-state :unevaluated :rule (c-lambda (without-c-dependency , at body)))) -(export! c?once) +(defmacro c?n-until (&body body) + `(make-c-dependent + :optimize :when-value-t + :code ',body + :inputp t + :value-state :unevaluated + :rule (c-lambda , at body))) + +(export! c?once c?n-until) (defmacro c?once (&body body) `(make-c-dependent :code '(without-c-dependency , at body) --- /project/cells/cvsroot/cells/link.lisp 2006/10/17 21:28:39 1.19 +++ /project/cells/cvsroot/cells/link.lisp 2006/10/28 18:20:48 1.20 @@ -24,8 +24,10 @@ (defun record-caller (used &aux (caller (car *call-stack*))) (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell + (trc nil "caller not being recorded because used optimized away" caller (c-value used) :used used) (return-from record-caller nil)) - (trc used "record-caller entry: used=" used :caller caller) + (trc nil "record-caller entry: used=" used :caller caller) + (multiple-value-bind (used-pos useds-len) (loop with u-pos for known in (cd-useds caller) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/10/17 21:28:39 1.29 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/10/28 18:20:48 1.30 @@ -65,7 +65,9 @@ ;; 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) - (c-validp c))) ;; a c?n (ruled-then-input) cell will not be valid at first + (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) + (null (c-value c)))))) ((or (not (c-validp c)) ;; @@ -236,7 +238,11 @@ (c-value-state c) :valid (c-state c) :awake) - (c-optimize-away?! c) ;;; put optimize test here to avoid needless linking + + (case (cd-optimize c) + ((t) (c-optimize-away?! c)) ;;; put optimize test here to avoid needless linking + (:when-value-t (when (c-value c) + (c-unlink-from-used c)))) ; --- data flow propagation ----------- (unless (eq propagation-code :no-propagate) @@ -251,24 +257,29 @@ (defun c-optimize-away?! (c) (when (and (typep c 'c-dependent) + (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) + (c-validp c) ;; /// when would this not be the case? (not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around) - ;; chop (every (lambda (lbl-syn) (null (cd-useds (cdr lbl-syn)))) (cd-synapses c)) - (not (c-inputp c)) - (null (cd-useds c))) - - (trc nil "optimizing away" c (c-state c)) + (not (c-inputp c)) ;; yes, dependent cells can be inputp + ) + (when (trcp c) (break "go optimizing ~a" c)) + (trc c "optimizing away" c (c-state c)) (count-it :c-optimized) (setf (c-state c) :optimized-away) - + (let ((entry (rassoc c (cells (c-model c))))) ; move from cells to cells-flushed + (unless entry + (describe c)) (c-assert entry) + (trc c "c-optimize-away?! moving cell to flushed list" c) (setf (cells (c-model c)) (delete entry (cells (c-model c)))) (push entry (cells-flushed (c-model c)))) - + (dolist (caller (c-callers c)) + (break "got opti of called") (setf (cd-useds caller) (delete c (cd-useds caller))) (c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...) ))) --- /project/cells/cvsroot/cells/md-utilities.lisp 2006/10/17 21:28:39 1.9 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2006/10/28 18:20:48 1.10 @@ -33,13 +33,18 @@ ;___________________ birth / death__________________________________ (defmethod not-to-be :around (self) - (trc nil "not-to-be nailing" self) + (trc nil "not-to-be nailing") (c-assert (not (eq (md-state self) :eternal-rest))) (call-next-method) - + (setf (fm-parent self) nil (md-state self) :eternal-rest) + + (md-map-cells self nil + (lambda (c) + (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not-to-be with primary method (use :before etc) + (trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self)) (defmethod not-to-be ((self model-object)) @@ -47,7 +52,7 @@ (md-quiesce self)) (defun md-quiesce (self) - (trc nil "md-quiesce doing" self (type-of self)) + (trc nil "md-quiesce nailing cells" self (type-of self)) (md-map-cells self nil (lambda (c) (trc nil "quiescing" c) (c-assert (not (find c *call-stack*))) @@ -56,13 +61,13 @@ (defun c-quiesce (c) (typecase c (cell - (trc c "c-quiesce unlinking" c) + (trc nil "c-quiesce unlinking" c) (c-unlink-from-used c) - (when (typep c 'cell) - (dolist (caller (c-callers c)) - (setf (c-value-state caller) :uncurrent) - (c-unlink-caller c caller))) - (trc nil "cell quiesce nulled cell awake" c)))) + (dolist (caller (c-callers c)) + (setf (c-value-state caller) :uncurrent) + (c-unlink-caller c caller)) + (setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho + ))) (defmethod not-to-be (other) other) --- /project/cells/cvsroot/cells/trc-eko.lisp 2006/10/17 21:28:39 1.4 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2006/10/28 18:20:48 1.5 @@ -85,9 +85,11 @@ (defmethod trcp :around (other) (unless (call-next-method other)(break))) +(export! trcp) + (defmethod trcp (other) (eq other t)) - + (defmethod trcp (($ string)) t) From ktilton at common-lisp.net Sat Oct 28 18:20:54 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 28 Oct 2006 14:20:54 -0400 (EDT) Subject: [cells-cvs] CVS cells/gui-geometry Message-ID: <20061028182054.6626D72088@common-lisp.net> Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv3409/gui-geometry Modified Files: geo-data-structures.lisp geo-family.lisp geometer.lisp gui-geometry.lpr Log Message: I forget. Some interesting stuff, I think. --- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/10/17 21:28:39 1.7 +++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/10/28 18:20:54 1.8 @@ -158,6 +158,12 @@ (defun r-top-left (r) (mkv2 (r-left r) (r-top r))) +(export! r-center) + +(defun r-center (r) + (mkv2 (/ (+ (r-left r)(r-right r)) 2) + (/ (+ (r-top r)(r-bottom r)) 2))) + (defun r-bottom-right (r) (mkv2 (r-bottom r) (r-right r))) --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/10/17 21:28:39 1.8 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/10/28 18:20:54 1.9 @@ -40,7 +40,7 @@ (ecase (orientation self) (:vertical (loop for k in (^kids) unless (collapsed k) - maximizing (pb k))) + minimizing (pb k))) (:horizontal (downs (loop for k in (^kids) maximizing (l-height k))))))) :kid-slots (lambda (self) --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/10/17 21:28:39 1.10 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/10/28 18:20:54 1.11 @@ -17,7 +17,7 @@ (in-package #:gui-geometry) (eval-now! - (export '(outset ^outset mkv2 g-offset g-offset-h g-offset-v))) + (export '(outset ^outset mkv2 g-offset g-offset-h g-offset-v collapsed ^collapsed))) (defmd geometer () px py ll lt lr lb @@ -341,7 +341,7 @@ (ecase justify (:top 0) (:center (floor (- (inset-height .parent) (l-height self)) -2)) - (:bottom (- (inset-height .parent) (l-height self)))))) + (:bottom (downs (- (inset-height .parent) (l-height self))))))) (defmacro ^fill-parent-right (&optional (inset 0)) `(lr-maintain-pr (- (inset-lr .parent) ,inset))) --- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/10/02 02:38:32 1.5 +++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/10/28 18:20:54 1.6 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Sat Oct 28 18:21:52 2006 From: ktilton at common-lisp.net (ktilton) Date: Sat, 28 Oct 2006 14:21:52 -0400 (EDT) Subject: [cells-cvs] CVS Celtk Message-ID: <20061028182152.28600B@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv3608 Modified Files: CELTK.lpr ltktest-ci.lisp run.lisp togl.lisp Log Message: --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/08/28 21:44:40 1.20 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/10/28 18:21:52 1.21 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- (in-package :cg-user) @@ -104,7 +104,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'celtk::tk-test + :on-initialization 'celtk::ltktest-ci :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/09/03 13:39:56 1.9 +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/10/28 18:21:52 1.10 @@ -119,6 +119,9 @@ ; which operates on the outside world via observers (on-change callbacks) triggered ; automatically by the Cells engine. See DEFOBSERVER. +(defun ctk::ltktest-ci () + (cells-reset 'tk-user-queue-handler) + (ctk:test-window 'ltktest-cells-inside)) (defmodel ltktest-cells-inside (window) () @@ -451,7 +454,4 @@ (defun mk-entry-numeric (&rest iargs) (apply 'make-instance 'entry-numeric :fm-parent *parent* iargs)) - -(defun ctk::ltktest-ci () - (cells-reset 'tk-user-queue-handler) - (ctk:test-window 'ltktest-cells-inside)) \ No newline at end of file + \ No newline at end of file --- /project/cells/cvsroot/Celtk/run.lisp 2006/10/02 02:56:01 1.21 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/10/28 18:21:52 1.22 @@ -138,7 +138,7 @@ ;; Our own event loop ! - Use this if it is desirable to do something ;; else between events -(defparameter *event-loop-delay* 0.08 "Minimum delay [s] in event loop not to lock out IDE (ACL anyway)") +(defparameter *event-loop-delay* .10 "Minimum delay [s] in event loop not to lock out IDE (ACL anyway)") (defun tcl-do-one-event-loop () (loop while (plusp (tk-get-num-main-windows)) --- /project/cells/cvsroot/Celtk/togl.lisp 2006/10/02 02:56:01 1.21 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/10/28 18:21:52 1.22 @@ -208,6 +208,6 @@ (defmethod make-tk-instance ((self togl)) (with-integrity (:client `(:make-tk ,self)) (setf (gethash (^path) (dictionary .tkw)) self) - (trc "making togl!!!!!!!!!!!!" (path self)(tk-configurations self)) + (trc nil "making togl!!!!!!!!!!!!" (path self)(tk-configurations self)) (tk-format-now "togl ~a ~{~(~a~) ~a~^ ~}" (path self)(tk-configurations self))))