cells-cvs

cells-cvs@common-lisp.net

721 discussions

[cells-cvs] CVS cells/gui-geometry
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv2729/gui-geometry Modified Files: geo-data-structures.lisp geo-family.lisp geometer.lisp gui-geometry.lpr Log Message: --- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/12/12 15:58:42 1.9 +++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2007/11/30 16:51:19 1.10 @@ -17,7 +17,7 @@ (in-package :gui-geometry) (eval-now! - (export '(v2 mkv2))) + (export '(v2 mkv2 v2=))) ;----------------------------- (defstruct v2 --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/11/13 05:28:08 1.11 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2007/11/30 16:51:19 1.12 @@ -102,6 +102,47 @@ (^prior-sib-pr self (spacing .parent))))))))))) +(defun ^prior-sib-pb (self &optional (spacing 0)) ;; just keeping with -pt variant till both converted to defun + (bif (psib (find-prior self (kids .parent) + :test (lambda (sib) + (not (collapsed sib))))) + (eko (nil "^prior-sib-pb spc pb-psib -lt" (- (abs spacing)) (pb psib) (- (^lt))) + (+ (- (abs spacing)) ;; force spacing to minus(= down for OpenGL) + (pb psib))) + 0)) + +(defun centered-h? () + (c? (px-maintain-pl (round (- (inset-width .parent) (l-width self)) 2)))) + +(defun centered-v? () + (c? (py-maintain-pt (round (- (l-height .parent) (l-height self)) -2)))) + +;--------------- geo.row.flow ---------------------------- +(export! geo-row-flow) + +(defmodel geo-row-flow (geo-inline) + ((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz) + (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt) + (aligned :cell nil :initarg :aligned :initform nil :reader aligned)) + (:default-initargs + :lb (c? (geo-kid-wrap self 'pb)) + :kid-slots (lambda (self) + (declare (ignore self)) + + (list + (mk-kid-slot (py) + (c? (py-maintain-pt + (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) + (if (> (+ ph (l-width self)(outset .parent)) (l-width .parent)) + (^prior-sib-pb self (spacing-vt .parent)) + (^prior-sib-pt self)))))) + (mk-kid-slot (px) + (c? (px-maintain-pl + (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) + (if (> (+ ph (l-width self)(outset .parent)) (l-width .parent)) + 0 + ph))))))))) + #| archive (defmodel geo-row-fv (family-values geo-row)()) @@ -136,28 +177,8 @@ (pt psib)) 0)))))))) -;--------------- IGRowFlow ---------------------------- +|# + + -(defmodel geo-row-flow (geo-row) - ((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz) - (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt) - (aligned :cell nil :initarg :aligned :initform nil :reader aligned)) - (:default-initargs - :lb (c? (geo-kid-wrap self 'pb)) - :kid-slots (lambda (self) - (declare (ignore self)) - (list - (mk-kid-slot (py) - (c? (py-maintain-pt - (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) - (if (> (+ ph (l-width self)) (l-width .parent)) - (^prior-sib-pb self (spacing-vt .parent)) - (^prior-sib-pt self)))))) - (mk-kid-slot (px) - (c? (px-maintain-pl - (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent)))) - (if (> (+ ph (l-width self)) (l-width .parent)) - 0 - ph))))))))) -|# --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/11/13 05:28:08 1.12 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2007/11/30 16:51:19 1.13 @@ -87,18 +87,7 @@ ;(trc "inner outer" inner outer) )) -(defmacro ^offset-within (inner outer) - (let ((offset-h (gensym)) (offset-v (gensym)) (from (gensym))) - `(let ((,offset-h 0) - (,offset-v 0)) - (do ((,from ,inner (fm-parent ,from))) - ((or (null ,from) - (eql ,from ,outer)) - ; - (mkv2 ,offset-h ,offset-v)) - - (incf ,offset-h (px ,from)) - (incf ,offset-v (py ,from)))))) + ;----------- OfKids ----------------------- ; @@ -127,6 +116,8 @@ (v2-subtract outer-v2 (mkv2 (px inner) (py inner)))))) +(export! h-xlate v-xlate) + (defun h-xlate (outer inner outer-h) (if (eql outer inner) outer-h @@ -212,18 +203,6 @@ ;--------------------------------- -(defmacro ^ll-width (width) - `(- (lr self) ,width)) - -(defmacro ^lr-width (width) - `(+ (ll self) ,width)) - -(defmacro ^lt-height (height) - `(- (lb self) ,height)) - -(defmacro ^lb-height (height) - `(+ (lt self) ,height)) - ;---------------------------------- (export! geo-kid-wrap) @@ -235,108 +214,6 @@ ((pr pt) 'fm-max-kid)) self bound) (outset self))) -(defmacro ll-maintain-pL (pl) - `(- ,pL (^px))) - -(defmacro lr-maintain-pr (pr) - `(- ,pr (^px))) - -(defmacro ^fill-right (upperType &optional (padding 0)) - `(call-^fillRight self (upper self ,upperType) ,padding)) - -;recalc local top based on pT and offset -(defmacro lt-maintain-pT (pT) - `(- ,pT (^py))) - -;recalc local bottom based on pB and offset -(defmacro lb-maintain-pB (pB) - `(- ,pB (^py))) - -;-------------- -;recalc offset based on p and local -(defmacro px-maintain-pL (pL) - (let ((lL (gensym))) - `(- ,pL (let ((,lL (^lL))) - (c-assert ,lL () "^px-maintain-pL sees nil lL for ~a" self) - ,lL)))) - -(defmacro px-maintain-pR (pR) - `(- ,pR (^lR))) - -(defmacro py-maintain-pT (pT) - `(- ,pT (^lT))) - -(defmacro py-maintain-pB (pB) - `(- ,pB (^lB))) - -(defmacro centered-h? () - `(c? (px-maintain-pl (round (- (l-width .parent) (l-width self)) 2)))) - -(defmacro ^centered-v? () - `(c? (py-maintain-pt (round (- (l-height .parent) (l-height self)) 2)))) - -(defmacro ^fill-down (upper-type &optional (padding 0)) - (let ((filled (gensym))) - `(let ((,filled (upper self ,upper-type))) - #+qt (trc "^fillDown sees filledLR less offH" - (lb ,filled) - ,padding - (v2-v (offset-within self ,filled))) - (- (lb ,filled) - ,padding - (v2-v (offset-within self ,filled)))))) - -(defmacro ^lbmax? (&optional (padding 0)) - `(c? (lb-maintain-pb (- (inset-lb .parent) - ,padding)))) - -(defmacro ^lrmax? (&optional (padding 0)) - `(c? (lr-maintain-pr (- (inset-lr .parent) - ,padding)))) - -(defun ^prior-sib-pb (self &optional (spacing 0)) - (bif (psib (find-prior self (kids .parent) - :test (lambda (sib) - (not (collapsed sib))))) - (eko (nil "^prior-sib-pb spc pb-psib -lt" (- (abs spacing)) (pb psib) (- (^lt))) - (+ (- (abs spacing)) ;; force spacing to minus(= down for OpenGL) - (pb psib))) - 0)) - -(defmacro ^prior-sib-pt (self &optional (spacing 0)) - (let ((kid (gensym)) - (psib (gensym))) - `(let* ((,kid ,self) - (,psib (find-prior ,kid (kids (fm-parent ,kid))))) - ;(trc "^priorSib-pb > kid, sib" ,kid ,pSib) - (if ,psib - (+ (- (abs ,spacing)) (pt ,psib)) - 0)))) - -; "...return the sib's pL [if ,alignment is :left] or pR, plus optional spacing" - -(defmacro ^prior-sib-pr (self &optional (spacing 0) alignment) - (let ((kid (gensym)) - (psib (gensym))) - `(let* ((,kid ,self) - (,psib (find-prior ,kid (kids (fm-parent ,kid)) :test (lambda (k) (not (collapsed k)))))) - (if ,psib - (case ,alignment - (:left (+ ,spacing (pl ,psib))) - (otherwise (+ ,spacing (pr ,psib)))) - 0)))) - -(defmacro ^px-stay-right-of (other &key (by '0)) - `(px-maintain-pl (+ (pr (fm-other ,other)) ,by))) - -; in use; adjust offset to maintain pL based on ,justify -(defmacro ^px-self-centered (justify) - `(px-maintain-pl - (ecase ,justify - (:left 0) - (:center (floor (- (inset-width .parent) (l-width self)) 2)) - (:right (- (inset-lr .parent) (l-width self)))))) - ; in use; same idea for pT (defun py-self-centered (self justify) (py-maintain-pt @@ -345,9 +222,3 @@ (:center (floor (- (inset-height .parent) (l-height self)) -2)) (:bottom (downs (- (inset-height .parent) (l-height self))))))) -(defmacro ^fill-parent-right (&optional (inset 0)) - `(lr-maintain-pr (- (inset-lr .parent) ,inset))) - -(defmacro ^fill-parent-down () - `(lb-maintain-pb (inset-lb .parent))) - --- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2007/01/29 06:44:03 1.8 +++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2007/11/30 16:51:19 1.9 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jan 29, 2007 18:02)"; cg: "1.81"; -*- (in-package :cg-user) @@ -6,6 +6,7 @@ (define-project :name :gui-geometry :modules (list (make-instance 'module :name "defpackage.lisp") + (make-instance 'module :name "geo-macros.lisp") (make-instance 'module :name "geo-data-structures.lisp") (make-instance 'module :name "coordinate-xform.lisp")

1 0

[cells-cvs] CVS cells
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv2729 Modified Files: cell-types.lisp cells-manifesto.txt cells.lisp cells.lpr constructors.lisp defmodel.lisp defpackage.lisp family.lisp fm-utilities.lisp integrity.lisp link.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp propagate.lisp synapse-types.lisp synapse.lisp test-synapse.lisp trc-eko.lisp Log Message: --- /project/cells/cvsroot/cells/cell-types.lisp 2007/01/29 06:43:48 1.25 +++ /project/cells/cvsroot/cells/cell-types.lisp 2007/11/30 16:51:18 1.26 @@ -166,7 +166,7 @@ ;__________________ (defmethod c-print-value ((c c-ruled) stream) - (format stream "~a" (cond ((c-validp c) "<vld>") + (format stream "~a" (cond ((c-validp c) (cons (c-value c) "<vld>")) ((c-unboundp c) "<unb>") ((not (c-currentp c)) "dirty") (t "<err>")))) --- /project/cells/cvsroot/cells/cells-manifesto.txt 2006/10/11 22:16:20 1.10 +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2007/11/30 16:51:18 1.11 @@ -181,7 +181,7 @@ is guaranteed to be called at least once during intialization even if a cell slot is bound to a constant or if it is an input or ruled Cell that never changes value. -It is legal for observer code to assign to input Cells, but (a) special syntax is required to defer executuion +It is legal for observer code to assign to input Cells, but (a) special syntax is required to defer execution until the observed state change has fully propagated; and (b) doing so compromises the declarative quality of an application -- one can no longer look to one rule to see how a slot (in this case the input slot being assigned by the observer) gets its value. A reasonable usage might be one with @@ -205,8 +205,8 @@ by the change to X and will not be recomputed. - recomputations, when they read other datapoints, must see only values current with the new value of X. - Example: if A depends on B and X, and B depends on X, when A reads B it must return a value recomputed from - the new value of X. + Example: if A depends on B and X, and B depends on X, when X changes and A reads B and X to compute a + new value, B must return a value recomputed from the new value of X. - similarly, client observer callbacks must see only values current with the new value of X; and @@ -285,11 +285,19 @@ to Lisp-land. See the Cells-Gtk or Celtk projects. Also, a persistent CLOS implementation that must echo CLOS instance data into, say, SQL tables. -Prior Art +Prior Art (in increasing order of priorness (age)) --------- +Functional reactive programming: + This looks to be the most active, current, and vibrant subset of folks working on this sort of stuff. + Links: + FlapJax (FRP-powered web apps) http://www.flapjax-lang.org/ + http://lambda-the-ultimate.org/node/1771 + http://www.haskell.org/frp/ + FrTime (scheme FRP implementation, no great links) http://pre.plt-scheme.org/plt/collects/frtime/doc.txt + Adobe Adam, originally developed only to manage complex GUIs. [Adam] -COSI, a class-based Cells-alike used at STSCI to in software used to +COSI, a class-based Cells-alike used at STSCI in software used to schedule Hubble telescope viewing time. [COSI] Garnet's KR: http://www.cs.cmu.edu/~garnet/ @@ -304,13 +312,12 @@ http://www.cs.utk.edu/~bvz/quickplan.html Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963. -Steele himself cites Sketchpad as inexlicably unappreciated prior +Steele himself cites Sketchpad as inexplicably unappreciated prior art to his Constraints system: See also: The spreadsheet paradigm: http://www.cs.utk.edu/~bvz/active-value-spreadsheet.html The dataflow paradigm: http://en.wikipedia.org/wiki/Dataflow - Reactive programming: http://www.haskell.org/yampa/AFPLectureNotes.pdf Frame-based programming Definitive-programming --- /project/cells/cvsroot/cells/cells.lisp 2007/01/29 06:43:52 1.20 +++ /project/cells/cvsroot/cells/cells.lisp 2007/11/30 16:51:18 1.21 @@ -19,8 +19,12 @@ (eval-when (compile load) (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3)))) + + (in-package :cells) + + (defparameter *c-prop-depth* 0) (defparameter *causation* nil) @@ -32,6 +36,9 @@ (defparameter *client-queue-handler* nil) (defparameter *unfinished-business* nil) +#+test +(cells-reset) + (defun cells-reset (&optional client-queue-handler &key debug) (utils-kt-reset) (setf @@ -55,6 +62,11 @@ (defun c-stopped () *stop*) +(export! .stopped) + +(define-symbol-macro .stopped + (c-stopped)) + (defmacro c-assert (assertion &optional places fmt$ &rest fmt-args) (declare (ignorable assertion places fmt$ fmt-args)) #+(or)`(progn) --- /project/cells/cvsroot/cells/cells.lpr 2007/01/29 06:43:59 1.27 +++ /project/cells/cvsroot/cells/cells.lpr 2007/11/30 16:51:18 1.28 @@ -1,8 +1,8 @@ -;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Sep 14, 2007 21:56)"; cg: "1.81"; -*- (in-package :cg-user) -(defpackage :CELLS) +(defpackage :cells) (define-project :name :cells :modules (list (make-instance 'module :name "defpackage.lisp") --- /project/cells/cvsroot/cells/constructors.lisp 2007/01/29 06:43:59 1.16 +++ /project/cells/cvsroot/cells/constructors.lisp 2007/11/30 16:51:18 1.17 @@ -26,7 +26,7 @@ (defmacro c-lambda (&body body) `(c-lambda-var (slot-c) ,@body)) -(export! .cache-bound-p) +(export! .cache-bound-p c?+n) (defmacro c-lambda-var ((c) &body body) `(lambda (,c &aux (self (c-model ,c)) @@ -49,6 +49,13 @@ :value-state :unevaluated :rule (c-lambda ,@body))) +(defmacro c?+n (&body body) + `(make-c-dependent + :inputp t + :code ',body + :value-state :unevaluated + :rule (c-lambda ,@body))) + (defmacro c?n (&body body) `(make-c-dependent :code '(without-c-dependency ,@body) --- /project/cells/cvsroot/cells/defmodel.lisp 2006/12/12 15:58:42 1.12 +++ /project/cells/cvsroot/cells/defmodel.lisp 2007/11/30 16:51:18 1.13 @@ -17,7 +17,6 @@ |# (in-package :cells) - (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) @@ -197,3 +196,6 @@ (ddd (c-in nil) :cell :ephemeral) :superx 42 ;; default-initarg (:documentation "as if!"))) + + + --- /project/cells/cvsroot/cells/defpackage.lisp 2006/11/04 20:52:01 1.9 +++ /project/cells/cvsroot/cells/defpackage.lisp 2007/11/30 16:51:18 1.10 @@ -58,6 +58,6 @@ #:fm-kid-containing #:fm-find-if #:fm-ascendant-if #:c-abs #:fm-collect-if #:psib #:not-to-be #:ssibno #:c-debug #:c-break #:c-assert #:c-stop #:c-stopped #:c-assert #:.stop #:delta-diff - ) + #:wtrc #:wnotrc #:eko-if #:trc #:wtrc #:eko #:ekx #:trcp #:trcx) #+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) ) --- /project/cells/cvsroot/cells/family.lisp 2007/01/29 06:43:59 1.19 +++ /project/cells/cvsroot/cells/family.lisp 2007/11/30 16:51:18 1.20 @@ -28,7 +28,6 @@ (.value :initform nil :accessor value :initarg :value) (zdbg :initform nil :accessor dbg :initarg :dbg))) - (defmethod fm-parent (other) (declare (ignore other)) nil) --- /project/cells/cvsroot/cells/fm-utilities.lisp 2007/01/29 06:43:59 1.15 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2007/11/30 16:51:18 1.16 @@ -87,11 +87,11 @@ (or (funcall some-function parent) (fm-ascendant-some (fm-parent parent) some-function)))) -(defun fm-ascendant-if (self if-function) - (when (and self if-function) - (or (when (funcall if-function self) +(defun fm-ascendant-if (self test) + (when (and self test) + (or (when (funcall test self) self) - (fm-ascendant-if .parent if-function)))) + (fm-ascendant-if .parent test)))) (defun fm-descendant-if (self test) (when (and self test) @@ -105,11 +105,13 @@ (when (fm-includes node d2) node)))) -(defun fm-collect-if (tree test) +(defun fm-collect-if (tree test &optional skip-top dependently) (let (collection) (fm-traverse tree (lambda (node) - (when (funcall test node) - (push node collection)))) + (unless (and skip-top (eq node tree)) + (when (funcall test node) + (push node collection)))) + :with-dependency dependently) (nreverse collection))) (defun fm-value-dictionary (tree value-fn &optional include-top) @@ -159,6 +161,39 @@ (without-c-dependency (tv)))))) (values)) +(export! fm-traverse-bf) +(defun fm-traverse-bf (family applied-fn &optional (cq (make-fifo-queue))) + (when family + (flet ((process-node (fm) + (funcall applied-fn fm) + (when (kids fm) + (fifo-add cq (kids fm))))) + (process-node family) + (loop for x = (fifo-pop cq) + while x + do (mapcar #'process-node x))))) + +#+test-bf +(progn + (defmd bftree (family) + (depth 0 :cell nil) + (id (c? (klin self))) + :kids (c? (when (< (depth self) 4) + (loop repeat (1+ (depth self)) + collecting (make-kid 'bftree :depth (1+ (depth self))))))) + + (defun klin (self) + (when self + (if .parent + (cons (kid-no self) (klin .parent)) + (list 0)))) + + (defun test-bf () + (let ((self (make-instance 'bftree))) + (fm-traverse-bf self + (lambda (node) + (print (id node))))))) + (defun fm-ordered-p (n1 n2 &aux (top (fm-ascendant-common n1 n2))) (assert top) (fm-traverse top (lambda (n) @@ -213,7 +248,7 @@ ;; should be modified to go through 'gather', which should be the real fm-find-all ;; -(export! fm-do-up) +(export! fm-do-up fm-find-next fm-find-prior) (defun fm-do-up (self &optional (fn 'identity)) (when self @@ -554,7 +589,8 @@ (count-it :fm-find-one) (flet ((matcher (fm) (when diag - (trc "fm-find-one matcher sees name" (md-name fm) :ofthing fm :seeking md-name)) + (trc nil + "fm-find-one matcher sees name" (md-name fm) :ofthing (type-of fm) :seeking md-name global-search)) (when (and (eql (name-root md-name)(md-name fm)) (or (null (name-subscript md-name)) (eql (name-subscript md-name) (fm-pos fm))) --- /project/cells/cvsroot/cells/integrity.lisp 2007/01/29 06:44:00 1.17 +++ /project/cells/cvsroot/cells/integrity.lisp 2007/11/30 16:51:18 1.18 @@ -44,6 +44,9 @@ *within-integrity*) (defun call-with-integrity (opcode defer-info action) + (when (eq opcode :change) + (when (eq defer-info :focus) + (break "cwi focus change"))) (when *stop* (return-from call-with-integrity)) (if *within-integrity* @@ -76,7 +79,7 @@ (defun ufb-add (opcode continuation) (assert (find opcode *ufb-opcodes*)) - (when (and *no-tell* (eq opcode :tell-dependents)) + #+trythis (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)) @@ -109,27 +112,38 @@ ; (bwhen (uqp (fifo-peek (ufb-queue :tell-dependents))) (trcx finish-business uqp) - (DOlist (b (fifo-data (ufb-queue :tell-dependents))) + (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 + ; OLD THINKING, preserved for the record, but NO LONGER TRUE: + ; 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 there can be no dependents ; to "tell". I think. :) So... + ; END OF OLD THINKING ; + ; We now allow :awaken to change things so more dependents need to be told. The problem is the implicit + ; dependence on the /life/ of a model whenever there is a dependence on any /cell/ of that model. + ; md-quiesce currently just flags such slots as uncurrent -- maybe /that/ should change and those should + ; recalculate at once -- and then an /observer/ can run and ask for a new value from such an uncurrent cell, + ; which now knows it must recalculate. And that recalculation of course can and likely will come up with a new value + ; and perforce need to tell its dependents. So... + ; + ; I /could/ explore something other than the "uncurrent" kludge, but NCTM 2007 is coming up and + ; to be honest the idea of not allowing nested tells was enforcing a /guess/ that that should not + ; arise, and there was not even any perceived integrity whole being closed, it was just a gratuitous + ; QA trick, and indeed for a long time many nested tells were avoidable. But the case of the quiesced + ; dependent reverses the arrow and puts the burden on the prosecution to prove nested tells are a problem. + (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 2> ufb needs to tell dependnents after awakening")) - - (assert (null (fifo-peek (ufb-queue :tell-dependents)))) - + (trc "retelling dependenst, one new one being" uqp) + (go tell-dependents)) + ;--- process client queue ------------------------------ ; (when *stop* (return-from finish-business)) @@ -141,7 +155,7 @@ (just-do-it clientq)) (when (fifo-peek (ufb-queue :client)) #+shhh (ukt::fifo-browse (ufb-queue :client) (lambda (entry) - (trc "surprise client" entry))) + (trc "surprise client" entry))) (go handle-clients))) ;--- now we can reset ephemerals -------------------- ; --- /project/cells/cvsroot/cells/link.lisp 2007/01/29 06:44:01 1.23 +++ /project/cells/cvsroot/cells/link.lisp 2007/11/30 16:51:18 1.24 @@ -67,7 +67,8 @@ (zerop (sbit usage rpos))) (progn (count-it :unlink-unused) - (trc nil "c-unlink-unused" c :dropping-used (car useds)) + #+save (when (eq 'mathx::progress (c-slot-name c)) + (trc "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 2007/01/29 06:44:01 1.34 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2007/11/30 16:51:18 1.35 @@ -64,6 +64,8 @@ ;;; (mathx::show-time t) ;;; (ctk::app-time t)))) +(defvar *trc-ensure* nil) + (defun ensure-value-is-current (c debug-id ensurer) ; ; ensurer can be used cell propagating to callers, or an existing caller who wants to make sure @@ -78,7 +80,7 @@ (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 nil "EVIC yep: 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) @@ -100,15 +102,23 @@ (or (check-reversed (cdr useds)) (let ((used (car useds))) (ensure-value-is-current used :nested c) - (trc nil "comparing pulses (ensurer, used, used-changed): " c debug-id used (c-pulse-last-changed used)) + #+slow (trc c "comparing pulses (ensurer, 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) + #+slow (trc c "used changed and newer !!!!!!" c :oldpulse (c-pulse used) debug-id used :lastchg (c-pulse-last-changed used)) + #+shhh (when (trcp c) + (describe 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*) + #+slow (trc c "kicking off calc-set of" (c-validp c) (c-slot-name c) :vstate (c-value-state c) + :stamped (c-pulse c) :current-pulse *data-pulse-id*) (calculate-and-set c)) + ((mdead (c-value c)) + (trc "ensure-value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c)) + (let ((new-v (calculate-and-set c))) + (trc "ensure-value-is-current> GOT new value ~a" new-v))) + (t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) debug-id) (c-pulse-update c :valid-uninfluenced))) @@ -118,7 +128,7 @@ (bwhen (v (c-value c)) (if (mdead v) (progn - (trc "ensure-value not returning dead model object value" v) + (brk "ensure-value still got and still not returning ~a dead value ~a" c v) nil) v))) @@ -127,7 +137,8 @@ (when (c-stopped) (princ #\.) (return-from calculate-and-set)) - + + #-its-alive! (bwhen (x (find c *call-stack*)) ;; circularity (unless nil ;; *stop* (let ((stack (copy-list *call-stack*))) @@ -142,7 +153,7 @@ (setf caller-reiterated (eq caller c))) (c-break ;; break is problem when testing cells on some CLs "cell ~a midst askers (see above)" c) - (break)) + (break "see listener for cell rule cycle diagnotics")) (multiple-value-bind (raw-value propagation-code) (calculate-and-link c) @@ -160,7 +171,7 @@ (let ((*call-stack* (cons c *call-stack*)) (*defer-changes* t)) (assert (typep c 'c-ruled)) - (trc nil "calculate-and-link" c) + #+slow (trc *c-debug* "calculate-and-link" c) (cd-usage-clear-all c) (multiple-value-prog1 (funcall (cr-rule c) c) @@ -248,7 +259,7 @@ ; --- head off unchanged; this got moved earlier on 2006-06-10 --- (when (and (not (eq propagation-code :propagate)) - (eql prior-state :valid) + (find prior-state '(:valid :uncurrent)) (c-no-news c absorbed-value prior-value)) (trc nil "(setf md-slot-value) > early no news" propagation-code prior-state prior-value absorbed-value) (count-it :nonews) @@ -303,16 +314,23 @@ (setf (c-state c) :optimized-away) - (let ((entry (rassoc c (cells (c-model c))))) ; move from cells to cells-flushed + (let ((entry (rassoc c (cells (c-model c))))) (unless entry (describe c)) (c-assert entry) (trc nil "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)))) + #-its-alive! (push entry (cells-flushed (c-model c))) + ) (dolist (caller (c-callers c)) - (break "got opti of called") + ; + ; example: on window shutdown with a tool-tip displayed, the tool-tip generator got + ; kicked off and asked about the value of a dead instance. That returns nil, and + ; there was no other dependency, so the Cell then decided to optimize itself away. + ; of course, before that time it had a normal value on which other things depended, + ; so we ended up here. where there used to be a break. + ; (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 2007/01/29 06:44:01 1.12 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2007/11/30 16:51:18 1.13 @@ -33,7 +33,7 @@ (defgeneric mdead (self) (:method ((self model-object)) - (eq :eternal-rest (md-state SELF))) + (eq :eternal-rest (md-state self))) (:method (self) (declare (ignore self)) @@ -47,19 +47,19 @@ (:method :around ((self model-object)) (declare (ignorable self)) (trc nil #+not (typep self '(or mathx::problem mathx::prb-solvers mathx::prb-solver)) - "not-to-be nailing" self) - (c-assert (not (eq (md-state self) :eternal-rest))) + "not.to-be nailing" self) + ;;showpanic (c-assert (not (eq (md-state self) :eternal-rest))) + (unless (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) - (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))) + (trc nil "not.to-be cleared 2 fm-parent, eternal-rest" self)))) (defun md-quiesce (self) (trc nil "md-quiesce nailing cells" self (type-of self)) @@ -75,13 +75,11 @@ (c-unlink-from-used c) (dolist (caller (c-callers c)) (setf (c-value-state caller) :uncurrent) - (trc nil "c-quiesce unlinking caller" c) + (trc nil "c-quiesce unlinking caller and making uncurrent" :q c :caller caller) (c-unlink-caller c caller)) (setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho ))) - - (defparameter *to-be-dbg* nil) (defmacro make-kid (class &rest initargs) --- /project/cells/cvsroot/cells/model-object.lisp 2007/01/29 06:44:01 1.15 +++ /project/cells/cvsroot/cells/model-object.lisp 2007/11/30 16:51:18 1.16 @@ -143,8 +143,11 @@ ;; next is an indirect and brittle way to determine that a slot has already been output, ;; but I think anything better creates a run-time hit. ;; - (unless (md-slot-cell-flushed self slot-name) ;; slot will have been propagated just after cell was flushed - (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil))) + ;; until 2007-10 (unless (cdr (assoc slot-name (cells-flushed self))) ;; make sure not flushed + ;; but first I worried about it being slow keeping the flushed list /and/ searching, then + ;; I wondered why a flushed cell should not be observed, constant cells are. So Just Observe It + (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil)) + ((find (c-lazy c) '(:until-asked :always t)) (trc nil "md-awaken deferring c-awaken since lazy" @@ -224,9 +227,6 @@ (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)))) - ;----------------- navigation: slot <> initarg <> esd <> cell ----------------- #+cmu --- /project/cells/cvsroot/cells/propagate.lisp 2007/01/29 06:44:01 1.27 +++ /project/cells/cvsroot/cells/propagate.lisp 2007/11/30 16:51:18 1.28 @@ -46,7 +46,8 @@ (defun c-pulse-update (c key) (declare (ignorable key)) - (trc nil "!!!!!!! c-pulse-update updating !!!!!!!!!!" *data-pulse-id* c key :prior-pulse (c-pulse c)) + (unless (find key '(:valid-uninfluenced)) + (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*)) @@ -74,7 +75,7 @@ (princ #\.)(princ #\!) (return-from c-propagate)) (trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c))) - (trc nil "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c) + #+slow (trc c "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)) @@ -83,7 +84,7 @@ ; --- manifest new value as needed --- ; - ; 20061030 Trying not-to-be first because doomed instances may be interested in callers + ; 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 @@ -95,7 +96,7 @@ (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)))) + (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)) @@ -169,6 +170,8 @@ ; --- recalculate dependents ---------------------------------------------------- + + (defun c-propagate-to-callers (c) ; ; We must defer propagation to callers because of an edge case in which: @@ -186,26 +189,27 @@ (member (c-lazy caller) '(t :always :once-asked)))) (c-callers c)) (let ((causation (cons c *causation*))) ;; in case deferred - (TRC nil "c-propagate-to-callers > queueing notifying callers" (c-callers c)) + #+slow (TRC c "c-propagate-to-callers > queueing notifying callers" (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 (c-callers c)) #+c-debug (dolist (caller (c-callers c)) (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller)) - (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list... - (trc nil "PRE-prop-CHECK " c :caller caller (c-state caller) (c-lazy caller)) - (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))() "Precheck Caller ~a of ~a does not have it as used" caller c) - )) + #+c-debug (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list... + (trc nil "PRE-prop-CHECK " c :caller caller (c-state caller) (c-lazy caller)) + (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))() "Precheck Caller ~a of ~a does not have it as used" caller c) + )) (dolist (caller (progn #+not copy-list (c-callers c))) ;; following code may modify c-callers list... (trc nil "propagating to caller iterates" c :caller caller (c-state caller) (c-lazy caller)) (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))() "Caller ~a of ~a does not have it as used" caller c) - (trc nil "propagating to caller is used" c :caller caller) - (ensure-value-is-current caller :prop-from c)))))))) + #+slow (trc c "propagating to caller is used" c :caller caller (c-currentp c)) + (let ((*trc-ensure* (trcp c))) + (ensure-value-is-current caller :prop-from c))))))))) --- /project/cells/cvsroot/cells/synapse-types.lisp 2006/05/20 06:32:19 1.5 +++ /project/cells/cvsroot/cells/synapse-types.lisp 2007/11/30 16:51:18 1.6 @@ -18,6 +18,18 @@ (in-package :cells) +(export! f-find) + +(defmacro f-find (synapse-id sought where) + `(call-f-find ,synapse-id ,sought ,where)) + +(defun call-f-find (synapse-id sought where) + (with-synapse synapse-id () + (bif (k (progn + (find sought where))) + (values k :propagate) + (values nil :no-propagate)))) + (defmacro f-sensitivity (synapse-id (sensitivity &optional subtypename) &body body) `(call-f-sensitivity ,synapse-id ,sensitivity ,subtypename (lambda () ,@body))) --- /project/cells/cvsroot/cells/synapse.lisp 2006/07/24 05:03:08 1.14 +++ /project/cells/cvsroot/cells/synapse.lisp 2007/11/30 16:51:18 1.15 @@ -19,7 +19,7 @@ (in-package :cells) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent))) + (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent with-synapse))) (defmacro with-synapse (synapse-id (&rest closure-vars) &body body) (let ((syn-id (gensym))(syn-caller (gensym))) @@ -40,7 +40,6 @@ (multiple-value-bind (v p) (with-integrity () (ensure-value-is-current synapse :synapse (car *call-stack*))) - (trc nil "with-synapse: synapse, v, prop" synapse v p) (values v p)) (record-caller synapse))))) --- /project/cells/cvsroot/cells/test-synapse.lisp 2005/12/09 18:59:33 1.1 +++ /project/cells/cvsroot/cells/test-synapse.lisp 2007/11/30 16:51:18 1.2 @@ -35,6 +35,7 @@ (print `(output m-syn-b ,self ,new-value ,old-value))) + (def-cell-test m-syn (progn (cell-reset) (let* ((delta-ct 0) --- /project/cells/cvsroot/cells/trc-eko.lisp 2007/01/29 06:44:01 1.6 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2007/11/30 16:51:18 1.7 @@ -22,8 +22,6 @@ (defparameter *trcdepth* 0) -(export! trc wtrc eko) - (defun trcdepth-reset () (setf *trcdepth* 0)) @@ -35,18 +33,31 @@ `(without-c-dependency (call-trc t ,tgt-form ,@os)) (let ((tgt (gensym))) + ;(break "slowww? ~a" tgt-form) `(without-c-dependency (bif (,tgt ,tgt-form) (if (trcp ,tgt) (progn - (assert (stringp ,(car os))) + (assert (stringp ,(car os)) () "trc with test expected string second, got ~a" ,(car os)) (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) (progn - ;; (break "trcfailed") + ;(trc "trcfailed") (count-it :trcfailed))) (count-it :tgtnileval))))))) -(export! trcx) +(export! brk brkx .bgo) + + +(define-symbol-macro .bgo (break "go")) + +(defun brk (&rest args) + #+its-alive! (print args) + #-its-alive! (progn + ;;(setf *ctk-dbg* t) + (apply 'break args))) + +(defmacro brkx (msg) + `(break "At ~a: OK?" ',msg)) (defmacro trcx (tgt-form &rest os) (if (eql tgt-form 'nil) @@ -60,6 +71,7 @@ (defparameter *last-trc* (get-internal-real-time)) (defun call-trc (stream s &rest os) + ;(break) (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) *trcdepth*) (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) @@ -85,8 +97,6 @@ (defmethod trcp :around (other) (unless (call-next-method other)(break))) -(export! trcp) - (defmethod trcp (other) (eq other t)) @@ -99,8 +109,6 @@ (defun trcdepth-decf () (format t "decrementing trc depth ~d" *trcdepth*) (decf *trcdepth*)) - -(export! wtrc eko-if) (defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body ) `(let ((*trcdepth* (if *trcdepth* @@ -121,11 +129,12 @@ ;------ eko -------------------------------------- - (defmacro eko ((&rest trcargs) &rest body) (let ((result (gensym))) `(let ((,result ,@body)) - (trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) + ,(if (stringp (car trcargs)) + `(trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) + `(trc ,(car trcargs) ,(cadr trcargs) :=> ,result ,@(cddr trcargs))) ,result))) (defmacro ekx (ekx-id &rest body) @@ -134,8 +143,6 @@ (trc ,(string-downcase (symbol-name ekx-id)) :=> ,result) ,result))) -(export! ekx) - (defmacro eko-if ((&rest trcargs) &rest body) (let ((result (gensym))) `(let ((,result ,@body)) @@ -148,4 +155,5 @@ `(let ((,result (,@body))) (when ,label (trc ,label ,result)) - ,result))) \ No newline at end of file + ,result))) +

1 0

[cells-cvs] CVS cells/cells-test
by ktilton 30 Nov '07

30 Nov '07

Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv2729/cells-test Modified Files: cells-test.lpr deep-cells.lisp test-synapse.lisp test.lisp Log Message: --- /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2006/06/10 22:16:35 1.6 +++ /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2007/11/30 16:51:19 1.7 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.1 [Windows] (Sep 29, 2007 20:23)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -25,64 +25,72 @@ :main-form nil :compilation-unit t :verbose nil - :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane - :cg.bitmap-pane.clipboard :cg.bitmap-stream - :cg.button :cg.caret :cg.check-box :cg.choice-list - :cg.choose-printer :cg.clipboard - :cg.clipboard-stack :cg.clipboard.pixmap - :cg.color-dialog :cg.combo-box :cg.common-control - :cg.comtab :cg.cursor-pixmap :cg.curve - :cg.dialog-item :cg.directory-dialog - :cg.directory-dialog-os :cg.drag-and-drop - :cg.drag-and-drop-image :cg.drawable - :cg.drawable.clipboard :cg.dropping-outline - :cg.edit-in-place :cg.editable-text - :cg.file-dialog :cg.fill-texture - :cg.find-string-dialog :cg.font-dialog - :cg.gesture-emulation :cg.get-pixmap - :cg.get-position :cg.graphics-context - :cg.grid-widget :cg.grid-widget.drag-and-drop - :cg.group-box :cg.header-control :cg.hotspot - :cg.html-dialog :cg.html-widget :cg.icon - :cg.icon-pixmap :cg.ie :cg.item-list - :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu - :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget - :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip - :cg.message-dialog :cg.multi-line-editable-text - :cg.multi-line-lisp-text :cg.multi-picture-button - :cg.multi-picture-button.drag-and-drop - :cg.multi-picture-button.tooltip :cg.ocx - :cg.os-widget :cg.os-window :cg.outline - :cg.outline.drag-and-drop - :cg.outline.edit-in-place :cg.palette - :cg.paren-matching :cg.picture-widget - :cg.picture-widget.palette :cg.pixmap - :cg.pixmap-widget :cg.pixmap.file-io - :cg.pixmap.printing :cg.pixmap.rotate :cg.printing - :cg.progress-indicator :cg.project-window - :cg.property :cg.radio-button :cg.rich-edit - :cg.rich-edit-pane :cg.rich-edit-pane.clipboard - :cg.rich-edit-pane.printing :cg.sample-file-menu - :cg.scaling-stream :cg.scroll-bar - :cg.scroll-bar-mixin :cg.selected-object - :cg.shortcut-menu :cg.static-text :cg.status-bar - :cg.string-dialog :cg.tab-control - :cg.template-string :cg.text-edit-pane - :cg.text-edit-pane.file-io :cg.text-edit-pane.mark - :cg.text-or-combo :cg.text-widget :cg.timer - :cg.toggling-widget :cg.toolbar :cg.tooltip - :cg.trackbar :cg.tray :cg.up-down-control - :cg.utility-dialog :cg.web-browser - :cg.web-browser.dde :cg.wrap-string - :cg.yes-no-list :cg.yes-no-string :dde) + :runtime-modules (list :cg-dde-utils :cg.base :cg.bitmap-pane + :cg.bitmap-pane.clipboard :cg.bitmap-stream + :cg.button :cg.caret :cg.check-box + :cg.choice-list :cg.choose-printer + :cg.clipboard :cg.clipboard-stack + :cg.clipboard.pixmap :cg.color-dialog + :cg.combo-box :cg.common-control :cg.comtab + :cg.cursor-pixmap :cg.curve :cg.dialog-item + :cg.directory-dialog :cg.directory-dialog-os + :cg.drag-and-drop :cg.drag-and-drop-image + :cg.drawable :cg.drawable.clipboard + :cg.dropping-outline :cg.edit-in-place + :cg.editable-text :cg.file-dialog + :cg.fill-texture :cg.find-string-dialog + :cg.font-dialog :cg.gesture-emulation + :cg.get-pixmap :cg.get-position + :cg.graphics-context :cg.grid-widget + :cg.grid-widget.drag-and-drop :cg.group-box + :cg.header-control :cg.hotspot :cg.html-dialog + :cg.html-widget :cg.icon :cg.icon-pixmap + :cg.ie :cg.item-list :cg.keyboard-shortcuts + :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane + :cg.lisp-text :cg.lisp-widget :cg.list-view + :cg.mci :cg.menu :cg.menu.tooltip + :cg.message-dialog + :cg.multi-line-editable-text + :cg.multi-line-lisp-text + :cg.multi-picture-button + :cg.multi-picture-button.drag-and-drop + :cg.multi-picture-button.tooltip :cg.ocx + :cg.os-widget :cg.os-window :cg.outline + :cg.outline.drag-and-drop + :cg.outline.edit-in-place :cg.palette + :cg.paren-matching :cg.picture-widget + :cg.picture-widget.palette :cg.pixmap + :cg.pixmap-widget :cg.pixmap.file-io + :cg.pixmap.printing :cg.pixmap.rotate + :cg.printing :cg.progress-indicator + :cg.project-window :cg.property + :cg.radio-button :cg.rich-edit + :cg.rich-edit-pane + :cg.rich-edit-pane.clipboard + :cg.rich-edit-pane.printing + :cg.sample-file-menu :cg.scaling-stream + :cg.scroll-bar :cg.scroll-bar-mixin + :cg.selected-object :cg.shortcut-menu + :cg.static-text :cg.status-bar + :cg.string-dialog :cg.tab-control + :cg.template-string :cg.text-edit-pane + :cg.text-edit-pane.file-io + :cg.text-edit-pane.mark :cg.text-or-combo + :cg.text-widget :cg.timer :cg.toggling-widget + :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray + :cg.up-down-control :cg.utility-dialog + :cg.web-browser :cg.web-browser.dde + :cg.wrap-string :cg.yes-no-list + :cg.yes-no-string :dde) :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") - :include-flags '(:top-level :debugger) - :build-flags '(:allow-runtime-debug :purify) + :include-flags (list :top-level :debugger) + :build-flags (list :allow-runtime-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil + :include-manifest-file-for-visual-styles t :default-command-line-arguments "+M +t \"Console for Debugging\"" - :additional-build-lisp-image-arguments '(:read-init-files nil) + :additional-build-lisp-image-arguments (list :read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard --- /project/cells/cvsroot/cells/cells-test/deep-cells.lisp 2006/03/22 04:08:35 1.2 +++ /project/cells/cvsroot/cells/cells-test/deep-cells.lisp 2007/11/30 16:51:19 1.3 @@ -34,12 +34,12 @@ (setf *client-log* (append *client-log* (list new-value)))))) (defun deep-queue-handler (client-q) - (loop for (nil . task) in (prog1 - (sort (fifo-data client-q) '< :key 'car) - (fifo-clear client-q)) - do + (loop for (defer-info . task) in (prog1 + (sort (fifo-data client-q) '< :key 'car) + (fifo-clear client-q)) + do (trc nil "!!! --- deep-queue-handler dispatching" defer-info) - (funcall task))) + (funcall task :user-q defer-info))) (def-cell-test go-deep () (cells-reset 'deep-queue-handler) --- /project/cells/cvsroot/cells/cells-test/test-synapse.lisp 2006/06/23 01:04:56 1.2 +++ /project/cells/cvsroot/cells/cells-test/test-synapse.lisp 2007/11/30 16:51:19 1.3 @@ -33,6 +33,29 @@ (defobserver m-syn-b () (print `(output m-syn-b ,self ,new-value ,old-value))) +(def-cell-test m-syn-bool + (let* ((delta-ct 0) + (m (make-instance 'm-syn + :m-syn-a (c-in nil) + :m-syn-b (c? (incf delta-ct) + (trc "syn-b containing rule firing!!!!!!!!!!!!!!" delta-ct) + (bwhen (msg (with-synapse :xyz42 () + (trc "synapse fires!!! ~a" (^m-syn-a)) + (bIF (k (find (^m-syn-a) '(:one :two :three))) + (values k :propagate) + (values NIL :no-propagate)))) + msg))))) + (ct-assert (= 1 delta-ct)) + (ct-assert (null (m-syn-b m))) + (setf (m-syn-a m) :nine) + (ct-assert (= 1 delta-ct)) + (ct-assert (null (m-syn-b m))) + (setf (m-syn-a m) :one) + (ct-assert (= 2 delta-ct)) + (ct-assert (eq :one (m-syn-b m))) + (setf (m-syn-a m) :nine) + (ct-assert (= 2 delta-ct)) + (ct-assert (eq :one (m-syn-b m))))) (def-cell-test m-syn (let* ((delta-ct 0) --- /project/cells/cvsroot/cells/cells-test/test.lisp 2006/11/04 20:52:01 1.9 +++ /project/cells/cvsroot/cells/cells-test/test.lisp 2007/11/30 16:51:19 1.10 @@ -68,8 +68,10 @@ #+go (test-cells) + (defun test-cells () (loop for test in (reverse *cell-tests*) + when (eq 'm-syn-bool test) do (cell-test-init test) (funcall test)) (print (make-string 40 :initial-element #\*))

1 0

[cells-cvs] CVS Celtk
by fgoenninger 16 Nov '07

16 Nov '07

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv7610 Modified Files: togl.lisp Log Message: Added: Some comments in the code - just to remember the why and how here and there ... Helped me to understand the code after having debugged it for a few hours ... Frank --- /project/cells/cvsroot/Celtk/togl.lisp 2007/01/29 06:48:42 1.25 +++ /project/cells/cvsroot/Celtk/togl.lisp 2007/11/16 10:09:31 1.26 @@ -50,6 +50,8 @@ (defcfun ("Togl_Interp" Togl-Interp) :pointer (togl-struct-ptr :pointer)) +;; The following functions are not CFFI-translated yet ... + ;; Togl_AllocColor ;; Togl_FreeColor @@ -80,8 +82,8 @@ ;; (defun tk-togl-init (interp) - ;(assert (not (zerop (tcl-init-stubs interp "8.1" 0)))) - ;(assert (not (zerop (tk-init-stubs interp "8.1" 0)))) + ;(assert (not (zerop (tcl-init-stubs interp "8.1" 0)))) ;; Only meaningful on Windows + ;(assert (not (zerop (tk-init-stubs interp "8.1" 0)))) ;; dito (togl-init interp) (togl-create-func (callback togl-create)) (togl-destroy-func (callback togl-destroy)) @@ -194,13 +196,17 @@ (def-togl-callback create () (trc "___________________ TOGL SET UP _________________________________________" togl-ptr ) -;;; ; -;;; ; just comment out these next 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) -;;; ; ^^^^^ above two needed only for cello ^^^^^^ -;;; ; + ;; + ;; Cello dependency here: relies on :CELLO being pushed to *features*! + ;; + ;;(eval-when (:compile-toplevel :execute) + ;; (if (member :cello cl-user::*features*) + ;; (progn + ;; (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)))) +;;; ^^^^^ above two needed only for cello ^^^^^^ +;;; (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))

1 0

[cells-cvs] CVS Celtk
by fgoenninger 16 Nov '07

16 Nov '07

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv7374 Modified Files: tk-interp.lisp Log Message: Added/Changed: Tile is not loaded on Mac OS X. (see function tk-interp-init-ensure) --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2007/01/29 22:58:41 1.18 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2007/11/16 10:06:50 1.19 @@ -22,13 +22,13 @@ ;; Tcl/Tk (define-foreign-library Tcl - (:darwin (:framework "Tcl")) + (:darwin (:framework "Tcl")) (:windows (:or "/tcl/bin/Tcl85.dll")) (:unix "libtcl.so") (t (:default "libtcl"))) (define-foreign-library Tk - (:darwin (:framework "Tk")) + (:darwin (:framework "Tk")) (:windows (:or "/tcl/bin/tk85.dll")) (:unix "libtk.so") (t (:default "libtk"))) @@ -42,7 +42,7 @@ (defctype tcl-retcode :int) (defcenum tcl-retcode-values - (:tcl-ok 0) + (:tcl-ok 0) (:tcl-error 1)) (defmethod translate-from-foreign (value (type (eql 'tcl-retcode))) @@ -63,16 +63,17 @@ (defcallback Tk_AppInit tcl-retcode ((interp :pointer)) - (tk-app-init interp)) + (unwind-protect + (tk-app-init interp))) (defun tk-app-init (interp) + (assert interp) (Tcl_Init interp) (Tk_Init interp) - ;;(format t "~%*** Tk_AppInit has been called.~%") ;; Return OK (foreign-enum-value 'tcl-retcode-values :tcl-ok)) - ;; Tk_Main + ;; Tk_Main (defcfun ("Tk_MainEx" %Tk_MainEx) :void (argc :int) @@ -91,7 +92,7 @@ (defcfun ("Tcl_CreateInterp" Tcl_CreateInterp) :pointer) (defcfun ("Tcl_DeleteInterp" tcl-delete-interp) :void - (interp :pointer)) + (interp :pointer)) ;;; --- windows ---------------------------------- @@ -113,29 +114,35 @@ (with-foreign-string (filename-cstr filename) (%Tcl_EvalFile interp filename-cstr))) -(defcfun ("Tcl_Eval" tcl-eval) tcl-retcode +(defcfun ("Tcl_Eval" %Tcl_Eval) tcl-retcode (interp :pointer) (script-cstr :string)) -(defcfun ("Tcl_EvalEx" tcl_evalex) tcl-retcode +(defun tcl-eval (i s) + (%Tcl_Eval i s)) + +(defcfun ("Tcl_EvalEx" %Tcl_EvalEx) tcl-retcode (interp :pointer) (script-cstr :string) - (num-bytes :int) - (flags :int)) + (num-bytes :int) + (flags :int)) (defun tcl-eval-ex (i s) - (tcl_evalex i s -1 0)) + (%Tcl_EvalEx i s -1 0)) -(defcfun ("Tcl_GetVar" tcl-get-var) :string (interp :pointer)(varName :string)(flags :int)) +(defcfun ("Tcl_GetVar" tcl-get-var) :string + (interp :pointer) + (varName :string) + (flags :int)) (defcfun ("Tcl_SetVar" tcl-set-var) :string - (interp :pointer) - (var-name :string) + (interp :pointer) + (var-name :string) (new-value :string) - (flags :int)) + (flags :int)) (defcfun ("Tcl_GetStringResult" tcl-get-string-result) :string - (interp :pointer)) + (interp :pointer)) ;; ---------------------------------------------------------------------------- ;; Tcl_CreateCommand - used to implement direct callbacks @@ -201,12 +208,13 @@ (unless *initialized* (use-foreign-library Tcl) (use-foreign-library Tk) - ;(use-foreign-library Tile) + #-macosx (use-foreign-library Tile) + #-macosx (pushnew :tile cl-user::*features*) (use-foreign-library Togl) (tcl-find-executable (argv0)) (set-initialized))) -;; Send a script to a piven Tcl/Tk interpreter +;; Send a script to a given Tcl/Tk interpreter (defun eval-script (interp script) (assert interp)

1 0

[cells-cvs] CVS Celtk
by fgoenninger 16 Nov '07

16 Nov '07

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv5819 Modified Files: scroll.lisp Log Message: Added: support for setting the font in a listbox (mk-scrolled-list ...) --- /project/cells/cvsroot/Celtk/scroll.lisp 2006/06/07 22:13:41 1.4 +++ /project/cells/cvsroot/Celtk/scroll.lisp 2007/11/16 10:01:44 1.5 @@ -37,7 +37,8 @@ (deftk scrolled-list (row-mixin frame-selector) ((list-item-keys :initarg :list-item-keys :accessor list-item-keys :initform nil) (list-item-factory :initarg :list-item-factory :accessor list-item-factory :initform nil) - (list-height :initarg :list-height :accessor list-height :initform nil)) + (list-height :initarg :list-height :accessor list-height :initform nil) + (tkfont :initarg :tkfont :accessor tkfont :initform (c-in '(courier 9)))) (:default-initargs :list-height (c? (max 1 (length (^list-item-keys)))) :kids-packing nil @@ -46,7 +47,7 @@ :kids (c? (the-kids (mapcar (list-item-factory .parent) (list-item-keys .parent)))) - :tkfont '(courier 9) + :tkfont (c? (tkfont .parent)) :state (c? (if (enabled .parent) 'normal 'disabled)) :takefocus (c? (if (enabled .parent) 1 0)) :height (c? (list-height .parent))

1 0

[cells-cvs] CVS Celtk
by fgoenninger 16 Nov '07

16 Nov '07

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv4278 Modified Files: composites.lisp Log Message: Changed: removed (break "Hunh?") - No need for that ;-) --- /project/cells/cvsroot/Celtk/composites.lisp 2007/01/29 06:48:41 1.23 +++ /project/cells/cvsroot/Celtk/composites.lisp 2007/11/16 09:57:46 1.24 @@ -146,8 +146,6 @@ (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)) @@ -163,28 +161,29 @@ ;;; Helper function that actually executes decoration change (defun %%do-decoration (widget decoration) - (break "hunh?") (let ((path (path widget))) - (ecase decoration - (:none (progn - (tk-format '(:pre-make-tk decoration) - "wm withdraw ~a" path) - (tk-format '(:pre-make-tk decoration) - "wm overrideredirect ~a 1" path) - (tk-format '(:pre-make-tk decoration) - "wm deiconify ~a" path) - (tk-format '(:pre-make-tk decoration) - "update idletasks" path) - )) - (:normal (progn - (tk-format '(:pre-make-tk decoration) - "wm withdraw ~a" path) - (tk-format '(:pre-make-tk decoration) - "wm overrideredirect ~a 0" path) - (tk-format '(:pre-make-tk decoration) - "wm deiconify ~a" path) - (tk-format '(:pre-make-tk decoration) - "update idletasks" path)))))) + (case decoration + (:none + (progn + (tk-format '(:pre-make-tk decoration) + "wm withdraw ~a" path) + (tk-format '(:pre-make-tk decoration) + "wm overrideredirect ~a 1" path) + (tk-format '(:pre-make-tk decoration) + "wm deiconify ~a" path) + (tk-format '(:pre-make-tk decoration) + "update idletasks" path) + )) + (:normal + (progn + (tk-format '(:pre-make-tk decoration) + "wm withdraw ~a" path) + (tk-format '(:pre-make-tk decoration) + "wm overrideredirect ~a 0" path) + (tk-format '(:pre-make-tk decoration) + "wm deiconify ~a" path) + (tk-format '(:pre-make-tk decoration) + "update idletasks" path)))))) ;;; Decoration observer for all widgets that inherit from decoration-mixin ;;; On Mac OS X this is a one-way operation. When created without decorations

1 0

[cells-cvs] CVS Celtk
by fgoenninger 16 Nov '07

16 Nov '07

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv4017 Modified Files: Celtk.lisp Log Message: Changed: :tile is not pushed onto *features* - needs to be done only when Tile is really loaded ... --- /project/cells/cvsroot/Celtk/Celtk.lisp 2007/01/29 22:58:41 1.40 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2007/11/16 09:55:26 1.41 @@ -16,9 +16,9 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.40 2007/01/29 22:58:41 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.41 2007/11/16 09:55:26 fgoenninger Exp $ -(pushnew :tile *features*) +;(pushnew :tile *features*) ;; frgo, 2007-09-21: Need to do this only when tile actually loaded (defpackage :celtk (:nicknames "CTK")

1 0

[cells-cvs] Undelivered Mail Returned to Sender
by MAILER-DAEMON＠common-lisp.net 19 Jul '07

19 Jul '07

This is the Postfix program at host reciever5.comendo.dk. I'm sorry to have to inform you that your message could not be delivered to one or more recipients. It's attached below. For further assistance, please send mail to <postmaster> If you do so, please include this problem report. You can delete your own text from the attached returned message. The Postfix program <-jg(a)pension.dk>: invalid recipient syntax: "-jg(a)pension.dk"

1 0

[cells-cvs] [SPAM] Perfect swiss replicas! this is what you need!
by Dona 07 Mar '07

07 Mar '07

Spam detection software, running on the system "clnet", has identified this incoming email as possible spam. The original message has been attached to this so you can view it (if it isn't spam) or label similar future email. If you have any questions, see the administrator of that system for details. Content preview: Debra Dear Sir or Madam, Attention please! [...] Content analysis details: (6.2 points, 5.0 required) pts rule name description ---- ---------------------- -------------------------------------------------- 0.2 INVALID_DATE Invalid Date: header (not RFC 2822) 4.4 HELO_DYNAMIC_IPADDR Relay HELO'd using suspicious hostname (IP addr 1) 1.6 DEAR_SOMETHING BODY: Contains 'Dear (something)' -1.1 BAYES_40 BODY: Bayesian spam probability is 20 to 40% [score: 0.3431] 1.0 MIME_HTML_MOSTLY BODY: Multipart message mostly text/html MIME 0.0 HTML_MESSAGE BODY: HTML included in message 0.1 MPART_ALT_DIFF BODY: HTML and text parts are different 0.0 MIME_QP_LONG_LINE RAW: Quoted-printable line longer than 76 chars 0.0 MANY_EXCLAMATIONS Subject has many exclamations The original message was not completely plain text, and may be unsafe to open with some email clients; in particular, it may contain a virus, or confirm that your address can receive spam. If you wish to view it, it may be safer to save it to a file and open it with an editor.

1 0

← Newer
1
...
20
21
22
23
24
25
26
...
73
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs