cells-cvs

cells-cvs@common-lisp.net

721 discussions

[cells-cvs] CVS Celtk
by ktilton 03 Sep '06

03 Sep '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv15575 Modified Files: entry.lisp ltktest-ci.lisp timer.lisp tk-object.lisp togl.lisp Log Message: --- /project/cells/cvsroot/Celtk/entry.lisp 2006/06/03 12:04:37 1.14 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/09/03 13:39:56 1.15 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.14 2006/06/03 12:04:37 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.15 2006/09/03 13:39:56 ktilton Exp $ (in-package :Celtk) @@ -40,10 +40,10 @@ :xscrollcommand (c-in nil) :textvariable (c? (intern (^path))) :event-handler (lambda (self xe) - (TRC nil "widget-event-handler" self (xsv type xe) ) + (TRC nil "ENTRY event-handler" self (xsv type xe) (tk-event-type (xsv type xe))) (case (tk-event-type (xsv type xe)) (:virtualevent - (trc nil "v/e" (xsv name xe)) + (trc nil "ENTRY virtual event" (xsv name xe)) (case (read-from-string (string-upcase (xsv name xe))) (trace (TRC nil "entry e/h trace" self (when (plusp (xsv user-data xe)) --- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/06/07 22:13:41 1.8 +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/09/03 13:39:56 1.9 @@ -99,7 +99,7 @@ ; to defer things until The Right Time. Which brings us back to Tk. Inspect the source of ; tk-user-queue-handler and search the Celtk source for "with-integrity (:client" to see how Celtk ; manages to talk to Tk in the order Tk likes. And hack the function tk-format-now to have - ; Celtk dump the TCL/Tk code being sent to wish during initialization, and notice how un-random it looks. You can + ; Celtk dump the code it has evaluated by TCL/Tk during initialization, and notice how un-random it looks. You can ; then comment out the above specification of a Tk-savvy handler to see (a) the order that would have happened ; before Cells3 and (b) the demo collapse in a broken heap. ; @@ -393,7 +393,6 @@ for y = (+ (* 50 (cos angle-2)) 200 (* 150 (cos w))) nconcing (list x y)))))) - (defun (setf moire-spin) (repeat self) (setf (repeat (car (timers self))) repeat)) ;; just hiding the implementation @@ -453,3 +452,6 @@ (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 --- /project/cells/cvsroot/Celtk/timer.lisp 2006/07/24 05:04:01 1.10 +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/09/03 13:39:56 1.11 @@ -74,10 +74,13 @@ (on-command :reader on-command :initform (lambda (self) - (when (eq (^state) :on) + (unless (md-dead self) + (trc nil "timer on-command dispatched!!!!!" self) + (when (eq (^state) :on) (assert (^action)) (funcall (^action) self) - (setf (^executed) t)))) + (setf (^executed) t))))) + (after-factory :reader after-factory :initform (c? (bwhen (rpt (when (eq (^state) :on) (^repeat))) @@ -92,7 +95,6 @@ (defobserver state ((self timer)) (unless (eq new-value :on) - (trc "bingo!!!!!!!!!!!!!!!!!!!!! state takes out timer" self) (cancel-timer self))) (defun set-timer (self time) --- /project/cells/cvsroot/Celtk/tk-object.lisp 2006/07/06 22:10:40 1.8 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2006/09/03 13:39:56 1.9 @@ -34,6 +34,11 @@ (user-errors :initarg :user-errors :accessor user-errors :initform nil)) (:documentation "Root class for widgets and (canvas) items")) +(defmethod not-to-be :before ((self tk-object)) + (loop for timer in (^timers) do + (setf (state timer) :off) + (not-to-be timer))) + (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self)) --- /project/cells/cvsroot/Celtk/togl.lisp 2006/08/28 21:44:40 1.18 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/09/03 13:39:56 1.19 @@ -185,8 +185,8 @@ (def-togl-callback create () (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) + ;;#+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 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

← Newer
1
...
26
27
28
29
30
31
32
...
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