cells-cvs August 2006

cells-cvs@common-lisp.net

1 participants
10 discussions

[cells-cvs] CVS cells
by ktilton 31 Aug '06

31 Aug '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv29838 Modified Files: fm-utilities.lisp Log Message: --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/08/21 04:29:30 1.8 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/08/31 17:35:28 1.9 @@ -223,6 +223,8 @@ (fm-traverse family traveller :global-search global-search))))) (when (and must-find (null matches)) (setf *stop* t) + (fm-traverse family (lambda (node) + (trc "known node" (md-name node))) :global-search global-search) (break "fm-find-all > *stop*ping...did not find ~a ~a ~a" family md-name global-search) ;; (error 'fm-not-found (list md-name family global-search)) )

1 0

[cells-cvs] CVS Celtk
by ktilton 28 Aug '06

28 Aug '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv27080 Modified Files: CELTK.lpr togl.lisp Log Message: --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/08/21 04:30:22 1.19 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/08/28 21:44:40 1.20 @@ -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) --- /project/cells/cvsroot/Celtk/togl.lisp 2006/08/21 04:30:23 1.17 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/08/28 21:44:40 1.18 @@ -157,6 +157,7 @@ (,height-var (togl-height ,togl-ptr))) ,@body)) + (defmacro def-togl-callback (root (&optional (ptr-var 'togl-ptr)(self-var 'self)) &body preamble) (let ((register$ (format nil "TOGL-~a-FUNC" root)) (cb$ (format nil "TOGL-~a" root)) @@ -183,9 +184,9 @@ (defmethod ,(intern uc$) ((self togl)))))) (def-togl-callback create () - (trc nil "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr self) - (setf cl-ftgl::*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready - + (trc "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" 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 + (ogl::kt-opengl-reset) (setf (togl-ptr self) togl-ptr) (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))

1 0

[cells-cvs] CVS cells
by ktilton 28 Aug '06

28 Aug '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv26989 Modified Files: cells.lpr family.lisp Log Message: --- /project/cells/cvsroot/cells/cells.lpr 2006/08/21 04:29:30 1.20 +++ /project/cells/cvsroot/cells/cells.lpr 2006/08/28 21:44:13 1.21 @@ -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) --- /project/cells/cvsroot/cells/family.lisp 2006/08/21 04:29:30 1.11 +++ /project/cells/cvsroot/cells/family.lisp 2006/08/28 21:44:13 1.12 @@ -123,13 +123,13 @@ (c-break "2nd adopt ~a, by ~a" self fm-parent)) (incf (adopt-ct self)) - + (trc nil "getting adopted" self :by fm-parent) (bwhen (kid-slots-fn (kid-slots (fm-parent self))) (dolist (ks-def (funcall kid-slots-fn self) self) (let ((slot-name (ks-name ks-def))) - (trc nil "got ksdef " slot-name) + (trc nil "got ksdef " slot-name (ks-if-missing ks-def)) (when (md-slot-cell-type selftype slot-name) - (trc nil "got cell type " slot-name) + (trc nil "got cell type " slot-name ) (when (or (not (ks-if-missing ks-def)) (and (null (c-slot-value self slot-name)) (null (md-slot-cell self slot-name))))

1 0

[cells-cvs] CVS cells
by ktilton 22 Aug '06

22 Aug '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv3291 Modified Files: cells.asd Log Message: --- /project/cells/cvsroot/cells/cells.asd 2006/07/06 22:10:01 1.5 +++ /project/cells/cvsroot/cells/cells.asd 2006/08/22 15:02:04 1.6 @@ -21,6 +21,7 @@ (:file "strings") (:file "datetime"))) (:file "defpackage") + (:file "trc-eko") (:file "cells") (:file "integrity") (:file "constructors")

1 0

[cells-cvs] CVS cells
by ktilton 22 Aug '06

22 Aug '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv1504 Added Files: trc-eko.lisp Log Message: Move trc utils into Cells project. --- /project/cells/cvsroot/cells/trc-eko.lisp 2006/08/22 14:59:37 NONE +++ /project/cells/cvsroot/cells/trc-eko.lisp 2006/08/22 14:59:37 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- #| The Newly Cells-aware TRC trace and EKO value echo facilities Copyright (C) 1995, 2006 by Kenneth Tilton This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :cells) ;----------- trc ------------------------------------------- (defparameter *trcdepth* 0) (export! trc wtrc eko) (defun trcdepth-reset () (setf *trcdepth* 0)) (defmacro trc (tgt-form &rest os) (if (eql tgt-form 'nil) '(progn) (if (stringp tgt-form) `(without-c-dependency (call-trc t ,tgt-form ,@os)) (let ((tgt (gensym))) `(without-c-dependency (bif (,tgt ,tgt-form) (if (trcp ,tgt) (progn (assert (stringp ,(car os))) (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) (progn ;; (break "trcfailed") (count-it :trcfailed))) (count-it :tgtnileval))))))) (defun call-trc (stream s &rest os) (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) *trcdepth*) (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) (format stream "~&")) (format stream "~a" s) (let (pkwp) (dolist (o os) (format stream (if pkwp " ~(~s~)" " __ ~(~s~)") o) (setf pkwp (keywordp o)))) (force-output stream) (values)) (defun call-trc-to-string (fmt$ &rest fmt-args) (let ((o$ (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t))) (with-output-to-string (os-stream o$) (apply 'call-trc os-stream fmt$ fmt-args)) o$)) #+findtrcevalnils (defmethod trcp :around (other) (unless (call-next-method other)(break))) (defmethod trcp (other) (eq other t)) (defmethod trcp (($ string)) t) (defun trcdepth-incf () (incf *trcdepth*)) (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* (1+ *trcdepth*) 0))) ,(when banner `(when (>= *trcdepth* ,min) (if (< *trcdepth* ,max) (trc ,@banner) (progn (break "excess trace notttt!!! ~d" *trcdepth*) ;; ,@banner) nil)))) (when (< *trcdepth* ,max) ,@body))) (defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body ) (declare (ignore min max banner)) `(progn ,@body)) ;------ eko -------------------------------------- (defmacro eko ((&rest trcargs) &rest body) (let ((result (gensym))) `(let ((,result ,@body)) (trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) ,result))) (defmacro eko-if ((&rest trcargs) &rest body) (let ((result (gensym))) `(let ((,result ,@body)) (when ,result (trc ,(car trcargs) :res ,result ,@(cdr trcargs))) ,result))) (defmacro ek (label &rest body) (let ((result (gensym))) `(let ((,result (,@body))) (when ,label (trc ,label ,result)) ,result)))

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 22 Aug '06

22 Aug '06

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv1504/utils-kt Modified Files: utils-kt.lpr Log Message: Move trc utils into Cells project. --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/08/21 04:29:31 1.16 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/08/22 14:59:38 1.17 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 10, 2006 12:19)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 17, 2006 12:24)"; cg: "1.81"; -*- (in-package :cg-user)

1 0

[cells-cvs] CVS Celtk
by ktilton 21 Aug '06

21 Aug '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv8987 Modified Files: CELTK.lpr tk-events.lisp togl.lisp widget.lisp Log Message: --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/07/24 05:04:01 1.18 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/08/21 04:30:22 1.19 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jul 19, 2006 19:38)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 17, 2006 12:24)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cells/cvsroot/Celtk/tk-events.lisp 2006/06/03 12:04:37 1.5 +++ /project/cells/cvsroot/Celtk/tk-events.lisp 2006/08/21 04:30:23 1.6 @@ -89,6 +89,8 @@ :DeactivateNotify :MouseWheelEvent) + + (defcenum tk-event-mask "Use to filter events when calling tk-create-event-handler" :NoEventMask --- /project/cells/cvsroot/Celtk/togl.lisp 2006/07/25 10:53:41 1.16 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/08/21 04:30:23 1.17 @@ -146,6 +146,7 @@ (:default-initargs :double t :rgba t + :alpha t :id (gentemp "TOGL") :ident (c? (^path)))) @@ -183,8 +184,7 @@ (def-togl-callback create () (trc nil "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr self) - (setf (togl-ptr self) (setf cl-ftgl::*ftgl-ogl* ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready - togl-ptr)) + (setf cl-ftgl::*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready (setf (togl-ptr self) togl-ptr) (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self)) --- /project/cells/cvsroot/Celtk/widget.lisp 2006/07/06 22:10:40 1.16 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/08/21 04:30:23 1.17 @@ -77,12 +77,18 @@ (defun tk-create-event-handler-ex (widget callback-name &rest masks) (let ((self-tkwin (widget-to-tkwin widget))) (assert (not (null-pointer-p self-tkwin))) - (trc nil "setting up widget virtual-event handler" widget :tkwin self-tkwin) + (trc nil "setting up widget virtual-event handler" widget callback-name :tkwin self-tkwin :masks masks) + (tk-create-event-handler self-tkwin + (foreign-masks-combine 'tk-event-mask :PointerMotionMask) + (get-callback callback-name) + self-tkwin) (tk-create-event-handler self-tkwin (apply 'foreign-masks-combine 'tk-event-mask masks) (get-callback callback-name) self-tkwin))) + + (defun widget-menu (self key) (or (find key (^menus) :key 'md-name) (break "The only menus I see are~{ ~a,~} not requested ~a" (mapcar 'md-name (^menus)) key))) @@ -124,12 +130,11 @@ (trc "widget-event-handler > no widget for tkwin ~a" client-data))) (defmethod widget-event-handle ((self widget) xe) ;; override for class-specific handling + (trc nil "bingo widget-event-handle" (xevent-type xe)) (bif (h (^event-handler)) ;; support instance-specific handlers (funcall h self xe) - #+shhh (case (xevent-type xe) - (:buttonpress - (trc "button pressed:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe))) - + (case (xevent-type xe) + (:buttonpress (trc "button pressed:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe))) (:buttonrelease (trc "button released:" (xbe button xe)(xbe x xe)(xbe y xe)(xbe x-root xe)(xbe y-root xe)))(:MotionNotify (xevent-dump xe)) (:virtualevent))))

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 21 Aug '06

21 Aug '06

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv8238/utils-kt Modified Files: debug.lisp defpackage.lisp detritus.lisp flow-control.lisp utils-kt.lpr Log Message: CVS sucks --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/07/25 10:51:48 1.9 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/08/21 04:29:31 1.10 @@ -20,7 +20,7 @@ (in-package :utils-kt) -(defparameter *trcdepth* 0) + (defvar *count* nil) (defvar *counting* nil) (defvar *dbg*) @@ -29,114 +29,10 @@ (defun utils-kt-reset () (setf *count* nil *stop* nil - *dbg* nil - *trcdepth* 0) + *dbg* nil) (print "----------UTILSRESET----------------------------------")) -;----------- trc ------------------------------------------- - -(defun trcdepth-reset () - (setf *trcdepth* 0)) - -(defmacro trc (tgt-form &rest os - &aux (wrapper (if (macro-function 'without-c-dependency) - 'without-c-dependency 'progn))) - (if (eql tgt-form 'nil) - '(progn) - (if (stringp tgt-form) - `(,wrapper - (call-trc t ,tgt-form ,@os)) - (let ((tgt (gensym))) - `(,wrapper - (bif (,tgt ,tgt-form) - (if (trcp ,tgt) - (progn - (assert (stringp ,(car os))) - (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) - (progn - ;; (break "trcfailed") - (count-it :trcfailed))) - (count-it :tgtnileval))))))) - -(defun call-trc (stream s &rest os) - (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) - *trcdepth*) - (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) - (format stream "~&")) - - (format stream "~a" s) - (let (pkwp) - (dolist (o os) - (format stream (if pkwp " ~s" " | ~s") o) - (setf pkwp (keywordp o)))) - (force-output stream) - (values)) - -(defun call-trc-to-string (fmt$ &rest fmt-args) - (let ((o$ (make-array '(0) :element-type 'base-char - :fill-pointer 0 :adjustable t))) - (with-output-to-string (os-stream o$) - (apply 'call-trc os-stream fmt$ fmt-args)) - o$)) - -#+findtrcevalnils -(defmethod trcp :around (other) - (unless (call-next-method other)(break))) - -(defmethod trcp (other) - (eq other t)) - -(defmethod trcp (($ string)) - t) - -(defun trcdepth-incf () - (incf *trcdepth*)) - -(defun trcdepth-decf () - (format t "decrementing trc depth ~d" *trcdepth*) - (decf *trcdepth*)) - -(export! wtrc) - -(defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body ) - `(let ((*trcdepth* (if *trcdepth* - (1+ *trcdepth*) - 0))) - ,(when banner `(when (>= *trcdepth* ,min) - (if (< *trcdepth* ,max) - (trc ,@banner) - (progn - (break "excess trace notttt!!! ~d" *trcdepth*) ;; ,@banner) - nil)))) - (when (< *trcdepth* ,max) - ,@body))) - -(defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body ) - (declare (ignore min max banner)) - `(progn ,@body)) - -;------ eko -------------------------------------- - -(defmacro eko ((&rest trcargs) &rest body) - (let ((result (gensym))) - `(let ((,result ,@body)) - (trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) - ,result))) - -(defmacro eko-if ((test &rest trcargs) &rest body) - (let ((result (gensym))) - `(let ((,result ,@body)) - (when ,test - (trc ,(car trcargs) :=> ,result ,@(cdr trcargs))) - ,result))) - -(defmacro ek (label &rest body) - (let ((result (gensym))) - `(let ((,result (,@body))) - (when ,label - (trc ,label ,result)) - ,result))) ;------------- counting --------------------------- --- /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2006/05/20 06:32:20 1.4 +++ /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2006/08/21 04:29:31 1.5 @@ -40,3 +40,27 @@ #-(or lispworks mcl) #:true #+(and mcl (not openmcl-partial-mop)) #:class-slots )) + +(in-package :utils-kt) + +(defmacro eval-now! (&body body) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@body)) + +(defmacro export! (&rest symbols) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (export ',symbols))) + +(defmacro define-constant (name value &optional docstring) + "Define a constant properly. If NAME is unbound, DEFCONSTANT +it to VALUE. If it is already bound, and it is EQUAL to VALUE, +reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again, +resulting in implementation-specific behavior." + `(defconstant ,name + (if (not (boundp ',name)) + ,value + (let ((value ,value)) + (if (equal value (symbol-value ',name)) + (symbol-value ',name) + value))) + ,@(when docstring (list docstring)))) --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/07/08 03:28:07 1.8 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/08/21 04:29:31 1.9 @@ -26,14 +26,6 @@ `(let ((*dbg* t)) ,@body)) -(defmacro eval-now! (&body body) - `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@body)) - -(defmacro export! (&rest symbols) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (export ',symbols))) - ;;;(defmethod class-slot-named ((classname symbol) slotname) ;;; (class-slot-named (find-class classname) slotname)) ;;; @@ -54,6 +46,11 @@ (defun xor (c1 c2) (if c1 (not c2) c2)) +(export! push-end) + +(defmacro push-end (item place ) + `(setf ,place (nconc ,place (list ,item)))) + ;;; --- FIFO Queue ----------------------------- (defun make-fifo-queue (&rest init-data) @@ -116,19 +113,6 @@ (loop until (fifo-empty q) do (print (fifo-pop q))))) -(defmacro define-constant (name value &optional docstring) - "Define a constant properly. If NAME is unbound, DEFCONSTANT -it to VALUE. If it is already bound, and it is EQUAL to VALUE, -reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again, -resulting in implementation-specific behavior." - `(defconstant ,name - (if (not (boundp ',name)) - ,value - (let ((value ,value)) - (if (equal value (symbol-value ',name)) - (symbol-value ',name) - value))) - ,@(when docstring (list docstring)))) #+allegro (defun line-count (path &optional show-files (depth 0)) @@ -165,3 +149,29 @@ :device "c" :directory `(:absolute "0dev" "Algebra")) t) +(export! tree-includes tree-traverse tree-intersect) + +(defun tree-includes (sought tree &key (test 'eql)) + (typecase tree + (null) + (atom (eko (nil "tree-inc? testing" sought tree) + (funcall test sought tree))) + (cons (loop for subtree in tree + when (tree-includes sought subtree :test test) + do (return-from tree-includes t))))) + +(defun tree-traverse (tree fn) + (typecase tree + (null) + (atom (funcall fn tree)) + (cons (loop for subtree in tree + do (tree-traverse subtree fn)))) + (values)) + +(defun tree-intersect (t1 t2 &key (test 'eql)) + (tree-traverse t1 + (lambda (t1-node) + (eko (nil "treeinter?" t1-node t2) + (when (tree-includes t1-node t2 :test test) + (return-from tree-intersect t1-node)))))) + --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/07/03 00:08:29 1.4 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/08/21 04:29:31 1.5 @@ -31,6 +31,8 @@ (defun min-if (v1 v2) (if v1 (if v2 (min v1 v2) v1) v2)) +(export! list-flatten!) + (defun list-flatten! (&rest list) (if (consp list) (let (head work visited) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/07/25 10:51:48 1.15 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/08/21 04:29:31 1.16 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jul 24, 2006 15:27)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 10, 2006 12:19)"; cg: "1.81"; -*- (in-package :cg-user)

1 0

[cells-cvs] CVS cells/gui-geometry
by ktilton 21 Aug '06

21 Aug '06

Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv8238/gui-geometry Modified Files: geo-data-structures.lisp geometer.lisp gui-geometry.lpr Log Message: CVS sucks --- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/07/06 22:10:02 1.5 +++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2006/08/21 04:29:31 1.6 @@ -17,7 +17,7 @@ (in-package :gui-geometry) (eval-now! - (export '(v2))) + (export '(v2 mkv2))) ;----------------------------- (defstruct v2 --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/07/25 10:51:48 1.7 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/08/21 04:29:31 1.8 @@ -17,7 +17,7 @@ (in-package #:gui-geometry) (eval-now! - (export '(outset ^outset))) + (export '(outset ^outset mkv2 g-offset g-offset-h g-offset-v))) (defmd geometer () px py ll lt lr lb --- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/06/29 09:54:06 1.3 +++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/08/21 04:29:31 1.4 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 17, 2006 12:24)"; cg: "1.81"; -*- (in-package :cg-user)

1 0

[cells-cvs] CVS cells
by ktilton 21 Aug '06

21 Aug '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv8238 Modified Files: cells.lisp cells.lpr defmodel.lisp family.lisp fm-utilities.lisp link.lisp md-slot-value.lisp md-utilities.lisp Log Message: CVS sucks --- /project/cells/cvsroot/cells/cells.lisp 2006/07/25 10:51:48 1.15 +++ /project/cells/cvsroot/cells/cells.lisp 2006/08/21 04:29:30 1.16 @@ -32,6 +32,7 @@ (defparameter *within-integrity* nil) (defparameter *client-queue-handler* nil) (defparameter *unfinished-business* nil) + (defun cells-reset (&optional client-queue-handler) (utils-kt-reset) (setf @@ -41,7 +42,8 @@ *defer-changes* nil ;; should not be necessary, but cannot be wrong *client-queue-handler* client-queue-handler *within-integrity* nil - *unfinished-business* nil) + *unfinished-business* nil + *trcdepth* 0) (trc nil "------ cell reset ----------------------------")) (defun c-stop (&optional why) @@ -132,7 +134,7 @@ (defun c-break (&rest args) (unless *stop* - (LET ((*print-level* 3) + (let ((*print-level* 3) (*print-circle* t) ) (c-stop args) --- /project/cells/cvsroot/cells/cells.lpr 2006/07/25 10:51:48 1.19 +++ /project/cells/cvsroot/cells/cells.lpr 2006/08/21 04:29:30 1.20 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jul 24, 2006 15:27)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 17, 2006 12:24)"; cg: "1.81"; -*- (in-package :cg-user) @@ -6,6 +6,7 @@ (define-project :name :cells :modules (list (make-instance 'module :name "defpackage.lisp") + (make-instance 'module :name "trc-eko.lisp") (make-instance 'module :name "cells.lisp") (make-instance 'module :name "integrity.lisp") (make-instance 'module :name "cell-types.lisp") --- /project/cells/cvsroot/cells/defmodel.lisp 2006/07/03 00:08:29 1.7 +++ /project/cells/cvsroot/cells/defmodel.lisp 2006/08/21 04:29:30 1.8 @@ -147,7 +147,7 @@ (when documentation-p (list :documentation documentation))))) (defmacro defmd (class superclasses &rest mdspec) - `(defmodel ,class ,superclasses + `(defmodel ,class (,@superclasses model) ,@(let (definitargs class-options slots) (loop with skip for (spec next) on mdspec --- /project/cells/cvsroot/cells/family.lisp 2006/07/06 22:10:01 1.10 +++ /project/cells/cvsroot/cells/family.lisp 2006/08/21 04:29:30 1.11 @@ -183,8 +183,9 @@ (declare (ignorable self)) (list ,@slot-defs))) -(defmethod md-name (symbol) - symbol) +(defmethod md-name (other) + (trc "yep other md-name" other (type-of other)) + other) (defmethod md-name ((nada null)) (unless (c-stopped) --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/05/20 06:32:19 1.7 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/08/21 04:29:30 1.8 @@ -195,6 +195,15 @@ ;; eventually fm-find-all needs a better name (as does fm-collect) and they ;; should be modified to go through 'gather', which should be the real fm-find-all ;; + +(export! fm-do-up) + +(defun fm-do-up (self &optional (fn 'identity)) + (when self + (funcall fn self) + (if .parent (fm-do-up .parent fn) self)) + (values)) + (defun fm-gather (family &key (test #'true-that)) (packed-flat! (cons (when (funcall test family) family) @@ -256,10 +265,11 @@ (when (funcall test-fn family) family)))) -(defun fm-prior-sib (self &optional (test-fn #'true-that) - &aux (kids (kids (fm-parent self)))) +(defun fm-prior-sib (self &optional (test-fn #'true-that)) "Find nearest preceding sibling passing TEST-FN" - (find-if test-fn kids :end (position self kids) :from-end t)) + (chk self 'psib) + (let ((kids (kids (fm-parent self)))) + (find-if test-fn kids :end (position self kids) :from-end t))) (defun fm-next-sib-if (self test-fn) (some test-fn (cdr (member self (kids (fm-parent self)))))) --- /project/cells/cvsroot/cells/link.lisp 2006/07/24 05:03:08 1.16 +++ /project/cells/cvsroot/cells/link.lisp 2006/08/21 04:29:30 1.17 @@ -56,12 +56,17 @@ ;--- unlink unused -------------------------------- -(defun c-unlink-unused (c &aux (usage (cd-usage c))) +(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)))) + (declare (ignorable usage-size)) (when (cd-useds c) (let (rev-pos) (labels ((nail-unused (useds) (flet ((handle-used (rpos) - (if (zerop (sbit usage rpos)) + (if (or (>= rpos usage-size) + (zerop (sbit usage rpos))) (progn (count-it :unlink-unused) (c-unlink-caller (car useds) c) @@ -75,6 +80,7 @@ (nail-unused (cdr useds)) (handle-used (incf rev-pos))) (handle-used (setf rev-pos 0)))))) + (trc dbg "cd-useds length" (length (cd-useds c)) c) (nail-unused (cd-useds c)) (setf (cd-useds c) (delete nil (cd-useds c))))))) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/07/25 10:51:48 1.26 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/08/21 04:29:30 1.27 @@ -47,10 +47,16 @@ (record-caller c))) (values (bd-slot-value self slot-name) nil))) +(defun chk (s &optional (key 'anon)) + (when (eq :eternal-rest (md-state s)) + (break "model ~a is dead at ~a" s key))) + (defun ensure-value-is-current (c debug-id caller) (declare (ignorable debug-id caller)) (count-it :ensure-value-is-current) (trc nil "ensure-value-is-current > 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 @@ -82,10 +88,12 @@ (princ #\.) (return-from calculate-and-set)) - (when (find c *call-stack*) ;; circularity - (trc "cell appears in call stack:" *stop*) + (bwhen (x (find c *call-stack*)) ;; circularity + (unless nil ;; *stop* + (let ((stack (copy-list *call-stack*))) + (trc "calculating cell ~a appears in call stack: ~a" c x stack ))) (setf *stop* t) - (break) + (c-break "yep" c) #+not (loop with caller-reiterated for caller in *call-stack* until caller-reiterated @@ -105,7 +113,7 @@ (md-slot-value-assume c raw-value propagation-code)))) (if nil ;; *dbg* - (ukt::wtrc (0 100 "calcnset" c) (body)) + (wtrc (0 100 "calcnset" c) (body)) (body)))) (defun calculate-and-link (c) --- /project/cells/cvsroot/cells/md-utilities.lisp 2006/06/23 01:04:56 1.6 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2006/08/21 04:29:30 1.7 @@ -30,7 +30,7 @@ ;___________________ birth / death__________________________________ (defmethod not-to-be :around (self) - (trc nil "not-to-be clearing 1 fm-parent, eternal-rest" self) + (trc nil "not-to-be nailing" self) (c-assert (not (eq (md-state self) :eternal-rest))) (call-next-method)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs August 2006