cells-cvs

cells-cvs@common-lisp.net

721 discussions

[cells-cvs] CVS cells/cells-test
by ktilton 11 Oct '08

11 Oct '08

Update of /project/cells/cvsroot/cells/cells-test In directory cl-net:/tmp/cvs-serv22971/cells-test Modified Files: cells-test.asd cells-test.lpr deep-cells.lisp person.lisp test.lisp Log Message: Just trying to get a patch in for record-caller --- /project/cells/cvsroot/cells/cells-test/cells-test.asd 2007/12/02 18:47:20 1.1 +++ /project/cells/cvsroot/cells/cells-test/cells-test.asd 2008/10/12 01:21:09 1.2 @@ -9,21 +9,18 @@ :long-description "Informatively-commented regression tests for Cells" :serial t :depends-on (:cells) - :components ((:module "cells-test" - :serial t - :components ((:file "test") - (:file "hello-world") - (:file "test-kid-slotting") - (:file "test-lazy") - (:file "person") - (:file "df-interference") - (:file "test-family") - (:file "output-setf") - (:file "test-cycle") - (:file "test-ephemeral") - (:file "test-synapse") - (:file "deep-cells"))))) + :components ((:file "test") + (:file "hello-world") + (:file "test-kid-slotting") + (:file "test-lazy") + (:file "person") + (:file "df-interference") + (:file "test-family") + (:file "output-setf") + (:file "test-cycle") + (:file "test-ephemeral") + (:file "test-synapse") + (:file "deep-cells"))) + -(defmethod perform :after ((op load-op) (system (eql (find-system :cells-test)))) - (funcall (find-symbol "TEST-CELLS" "CELLS"))) --- /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2008/04/22 14:50:56 1.10 +++ /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2008/10/12 01:21:09 1.11 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Apr 3, 2008 23:47)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -16,8 +16,11 @@ (make-instance 'module :name "test-cycle.lisp") (make-instance 'module :name "test-ephemeral.lisp") (make-instance 'module :name "test-synapse.lisp") - (make-instance 'module :name "deep-cells.lisp")) - :projects (list (make-instance 'project-module :name "..\\cells")) + (make-instance 'module :name "deep-cells.lisp") + (make-instance 'module :name "clos-training.lisp") + (make-instance 'module :name "do-req.lisp")) + :projects (list (make-instance 'project-module :name "..\\cells" + :show-modules nil)) :libraries nil :distributed-files nil :internally-loaded-files nil @@ -94,6 +97,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard + :build-number 0 :on-initialization 'cells::test-cells :on-restart 'do-default-restart) --- /project/cells/cvsroot/cells/cells-test/deep-cells.lisp 2007/11/30 16:51:19 1.3 +++ /project/cells/cvsroot/cells/cells-test/deep-cells.lisp 2008/10/12 01:21:09 1.4 @@ -4,9 +4,9 @@ (defvar *obs-1-count*) (defmodel deep () - ((cell-2 :cell :ephemeral :initform (c-in 'two) :accessor :cell-2) - (cell-1 :initform (c? (list 'one (^cell-2) (^cell-3))) :accessor :cell-1) - (cell-3 :initform (c-in 'c3-unset) :accessor :cell-3))) + ((cell-2 :cell :ephemeral :initform (c-in 'two) :accessor cell-2) + (cell-1 :initform (c? (list 'one (^cell-2) (^cell-3))) :accessor cell-1) + (cell-3 :initform (c-in 'c3-unset) :accessor cell-3))) (defobserver cell-1 () (trc "cell-1 observer raw now enqueing client to run first. (new,old)=" new-value old-value) --- /project/cells/cvsroot/cells/cells-test/person.lisp 2007/11/30 22:29:06 1.4 +++ /project/cells/cvsroot/cells/cells-test/person.lisp 2008/10/12 01:21:09 1.5 @@ -36,6 +36,16 @@ (incf *name-ct-calc*) (length (names self)))))) +#+test +(progn + (cells-reset) + (inspect + (make-instance 'person + :names '("speedy" "chill") + :pulse (c-in 60) + :speech (c? (car (names self))) + :thought (c? (when (< (pulse self) 100) (speech self)))))) + (defobserver names ((self person) new-names) (format t "~&you can call me ~a" new-names)) @@ -124,6 +134,8 @@ ;; (ct-assert (null (thought p))))) + + (def-cell-test cv-test-person-3 () ;; ------------------------------------------------------- ;; dynamic dependency graph maintenance @@ -154,6 +166,7 @@ (setf (pulse p) 50) (ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))))) + (def-cell-test cv-test-person-4 () (let ((p (make-instance 'person :names '("speedy" "chill") @@ -167,8 +180,10 @@ ;; - all cells accessed are constant. ;; (ct-assert (null (md-slot-cell p 'speech))) - (ct-assert (assoc 'speech (cells-flushed p))) - (ct-assert (c-optimized-away-p (cdr (assoc 'speech (cells-flushed p))))) + #-its-alive! + (progn + (ct-assert (assoc 'speech (cells-flushed p))) + (ct-assert (c-optimized-away-p (cdr (assoc 'speech (cells-flushed p)))))) (ct-assert (not (c-optimized-away-p (md-slot-cell p 'thought)))) ;; pulse is variable, so cannot opti (ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))) ;; but speech is opti, so only 1 used @@ -195,6 +210,8 @@ ;; make sure cyclic dependencies are trapped: ;; (cells-reset) + #+its-alive! t + #-its-alive! (ct-assert (handler-case (progn @@ -205,10 +222,9 @@ (length (names self))))) nil) (t (error) - (describe error) + (describe error) (setf *stop* nil) - t))) - ) + t)))) ;; ;; we'll toss off a quick class to test tolerance of cyclic --- /project/cells/cvsroot/cells/cells-test/test.lisp 2008/02/16 05:04:55 1.12 +++ /project/cells/cvsroot/cells/cells-test/test.lisp 2008/10/12 01:21:09 1.13 @@ -69,15 +69,21 @@ (defun test-cells () - (loop for test in (reverse *cell-tests*) - when t ; (eq 'cv-test-person-5 test) - do (cell-test-init test) - (funcall test)) - (print (make-string 40 :initial-element #\*)) - (print (make-string 40 :initial-element #\*)) - (print "*** Cells-test successfully completed **") - (print (make-string 40 :initial-element #\*)) - (print (make-string 40 :initial-element #\*))) + (dribble "c:/0algebra/cells-test.txt") + (progn ;prof:with-profiling (:type :time) + (time + (progn + (loop for test in (reverse *cell-tests*) + when t ; (eq 'cv-test-person-5 test) + do (cell-test-init test) + (funcall test)) + (print (make-string 40 :initial-element #\*)) + (print (make-string 40 :initial-element #\*)) + (print "*** Cells-test successfully completed **") + (print (make-string 40 :initial-element #\*)) + (print (make-string 40 :initial-element #\*))))) + ;(prof:show-call-graph) + (dribble)) (defun cell-test-init (name) (print (make-string 40 :initial-element #\!))

1 0

[cells-cvs] CVS cells/gui-geometry
by ktilton 11 Oct '08

11 Oct '08

Update of /project/cells/cvsroot/cells/gui-geometry In directory cl-net:/tmp/cvs-serv22971/gui-geometry Modified Files: defpackage.lisp geo-family.lisp geometer.lisp Log Message: Just trying to get a patch in for record-caller --- /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp 2008/01/29 04:29:54 1.7 +++ /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp 2008/10/12 01:21:09 1.8 @@ -16,7 +16,7 @@ (defpackage #:gui-geometry (:nicknames #:geo) - (:use #:common-lisp #:utils-kt #:cells) + (:use #:common-lisp #:excl #:utils-kt #:cells) (:export #:geometer #:geo-zero-tl #:geo-inline #:a-stack #:a-row #:px #:py #:ll #:lt #:lr #:lb #:pl #:pt #:pr #:pb #:^px #:^py #:^ll #:^lt #:^lr #:^lb #:^lb-height --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2008/06/16 12:38:04 1.14 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2008/10/12 01:21:09 1.15 @@ -17,7 +17,7 @@ (in-package :gui-geometry) (export! geo-inline-lazy ^px-self-centered justify py-maintain-pt - ^prior-sib-pb spacing lr-maintain-pr) + ^prior-sib-pb spacing lr-maintain-pr orientation) ;--------------- geo-inline ----------------------------- ; @@ -146,7 +146,10 @@ (setf pl 0 pt (+ max-pb (downs (^spacing-vt)))) - collect (cons pl pt) into pxys + collect (cons (+ pl (case (justify self) + (:center (/ (- kw (l-width k)) 2)) + (:right (- kw (l-width k))) + (otherwise 0))) pt) into pxys do (incf pl (+ kw (^spacing-hz))) (setf max-pb (min max-pb (+ pt (downs (l-height k))))) finally (return (cons max-pb pxys))))) --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2008/04/22 10:11:50 1.15 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2008/10/12 01:21:09 1.16 @@ -61,7 +61,7 @@ ;---------- gOffset ------------------- -(export! offset-within) +(export! offset-within inset-lb) ; (defun offset-within (inner outer &optional dbg) (declare (ignorable dbg)) @@ -212,6 +212,9 @@ (defun inset-lb (self) (+ (lb self) (outset self))) +(defun inset-lt (self) + (downs (lt self) (outset self))) + (defun inset-height (self) (- (l-height self) (outset self) (outset self))) @@ -219,7 +222,7 @@ ;---------------------------------- -(export! geo-kid-wrap) +(export! geo-kid-wrap inset-lt) (defun geo-kid-wrap (self bound) (funcall (ecase bound ((pl pb) '-)((pr pt) '+))

1 0

[cells-cvs] Viagra and Cialis will help you anytime.
by Florence 09 Jul '08

09 Jul '08

Can't find proper medication for your penis? Legal and quality medications at low price only. Cheap way to boost your sexual strength! Forget about problems with Canadian pharmacy! http://harngu.edikalpeng.com/?62829468 High-quality service is guaranteed

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 16 Jun '08

16 Jun '08

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv8789/utils-kt Modified Files: core.lisp debug.lisp detritus.lisp flow-control.lisp Log Message: nothing special --- /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/04/23 03:20:10 1.9 +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/06/16 12:38:04 1.10 @@ -46,41 +46,26 @@ value))) ,@(when docstring (list docstring))))) - -(export! exe-path exe-dll font-path) - -#-iamnotkenny -(defun exe-path () - #+its-alive! - (excl:current-directory) - #-its-alive! +(defun test-setup (&optional drib) + #+(and allegro ide) + (ide.base::find-new-prompt-command + (cg.base::find-window :listener-frame)) + (when drib + (dribble (merge-pathnames + (make-pathname :name drib :type "TXT") + (project-path))))) + +(export! test-setup test-prep test-init) +(export! project-path) +(defun project-path () + #+(and allegro ide) (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) -#-iamnotkenny -(defun font-path () - (merge-pathnames - (make-pathname - :directory #+its-alive! (list :relative "font") - #-its-alive! (append (butlast (pathname-directory - (exe-path) - )) - (list "TY Extender" "font"))) - (exe-path))) - #+test -(list (exe-path)(font-path)) +(test-setup) -(defmacro exe-dll (&optional filename) - (assert filename) - (concatenate 'string filename ".dll")) +(defun test-prep (&optional drib) + (test-setup drib)) -#+chya -(defun exe-dll (&optional filename) - (merge-pathnames - (make-pathname :name filename :type "DLL" - :directory (append (butlast (pathname-directory (exe-path))) - (list "dll"))) - (exe-path))) - -#+test -(probe-file (exe-dll "openal32")) +(defun test-init (&optional drib) + (test-setup drib)) \ No newline at end of file --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/03/15 15:18:34 1.19 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/06/16 12:38:04 1.20 @@ -55,13 +55,13 @@ (defmacro count-it (&rest keys) (declare (ignorable keys)) - #+(or) `(progn) - `(when (car *counting*) + `(progn) + #+(or) `(when (car *counting*) (call-count-it ,@keys))) (defun call-count-it (&rest keys) (declare (ignorable keys)) - (when (find (car keys) '(:trcfailed :TGTNILEVAL)) + #+nahh (when (find (car keys) '(:trcfailed :TGTNILEVAL)) (break "clean up time ~a" keys)) (let ((entry (assoc keys *count* :test #'equal))) (if entry @@ -85,6 +85,7 @@ (when clearp (count-clear "show-count"))) + ;-------------------- timex --------------------------------- (export! timex) --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/03/15 15:18:34 1.20 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/06/16 12:38:04 1.21 @@ -59,30 +59,6 @@ (defun collect-if (test list) (remove-if-not test list)) -(defun test-setup (&optional drib) - #-(or iamnotkenny its-alive!) - (ide.base::find-new-prompt-command - (cg.base::find-window :listener-frame)) - (when drib - (dribble (merge-pathnames - (make-pathname :name drib :type "TXT") - (project-path))))) - -(export! project-path) -(defun project-path () - #+allegro (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) - -#+test -(test-setup) - -(defun test-prep (&optional drib) - (test-setup drib)) - -(defun test-init (&optional drib) - (test-setup drib)) - -(export! test-setup test-prep test-init) - ;;; --- FIFO Queue ----------------------------- (defun make-fifo-queue (&rest init-data) --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/03/15 15:18:34 1.13 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/06/16 12:38:04 1.14 @@ -150,11 +150,15 @@ (defun -1?1 (x) (* -1?1 x)) (defun prime? (n) - (and (> n 1) - (or (= 2 n)(oddp n)) - (loop for d upfrom 3 by 2 to (sqrt n) - when (zerop (mod n d)) return nil - finally (return t)))) + (when (> n 1) + (cond + ((= 2 n) t) + ((evenp n) (values nil 2)) + (t (loop for d upfrom 3 by 2 to (sqrt n) + when (zerop (mod n d)) do (return-from prime? (values nil d)) + finally (return t)))))) + + ; --- cloucell support for struct access of slots ------------------------

1 0

[cells-cvs] CVS cells
by ktilton 16 Jun '08

16 Jun '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv8789 Modified Files: cells-manifesto.txt cells.lisp defmodel.lisp family.lisp fm-utilities.lisp integrity.lisp link.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp propagate.lisp test-propagation.lisp trc-eko.lisp Log Message: nothing special --- /project/cells/cvsroot/cells/cells-manifesto.txt 2008/03/15 15:18:34 1.13 +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2008/06/16 12:38:03 1.14 @@ -13,8 +13,8 @@ (make-instance 'menu-item :label "Cut" :enabled (c? (bwhen (f (focus *window*)) - (and (typep focus 'text-widget) - (selection-range focus))))) + (and (typep f 'text-widget) + (selection-range f))))) Translated, the enabled state of the Cut menu item follows whether or not the user is focused on a text-edit widget and @@ -102,7 +102,9 @@ in principle impossible. Which brings us to Cells. See also [axiom] Phillip Eby's developing axiomatic -definition he is developing in support of Ryan Forseth's SoC project. +definition he is developing in support of Ryan Forseth's SoC project. Mr. Eby was +inspired by his involvement to develop Trellis, his own Cells work-alike library +for Python. DEFMODEL and Slot types ----------------------- @@ -351,6 +353,9 @@ http://portal.acm.org/citation.cfm?id=889490&dl=ACM&coll=ACM http://www.cs.utk.edu/~bvz/quickplan.html +Flow-based programming, developed by J. Paul Morrison at IBM, 1971. + http://en.wikipedia.org/wiki/Flow-based_programming + Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963. Steele himself cites Sketchpad as inexplicably unappreciated prior art to his Constraints system: --- /project/cells/cvsroot/cells/cells.lisp 2008/04/23 03:20:09 1.28 +++ /project/cells/cvsroot/cells/cells.lisp 2008/06/16 12:38:03 1.29 @@ -150,30 +150,31 @@ (break "~&i say, unhandled <c-enabling>: ~s" condition)))) (define-condition c-fatal (xcell) - ((name :initarg :name :reader name) - (model :initarg :model :reader model) - (cell :initarg :cell :reader cell)) + ((name :initform :anon :initarg :name :reader name) + (model :initform nil :initarg :model :reader model) + (cell :initform nil :initarg :cell :reader cell)) (:report (lambda (condition stream) (format stream "~&fatal cell programming error: ~s" condition) (format stream "~& : ~s" (name condition)) (format stream "~& : ~s" (model condition)) (format stream "~& : ~s" (cell condition))))) -(define-condition c-unadopted (c-fatal) - () + +(define-condition asker-midst-askers (c-fatal) + ()) +;; "see listener for cell rule cycle diagnotics" + +(define-condition c-unadopted (c-fatal) () (:report (lambda (condition stream) (format stream "~&unadopted cell >: ~s" (cell condition)) (format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error")))) - (defun c-break (&rest args) (unless *stop* (let ((*print-level* 5) (*print-circle* t) (args2 (mapcar 'princ-to-string args))) - (c-stop args) - - (format t "~&c-break > stopping > ~{~a ~}" args2) - (print `(c-break-args ,@args2)) + (c-stop :c-break) + ;(format t "~&c-break > stopping > ~{~a ~}" args2) (apply 'error args2)))) \ No newline at end of file --- /project/cells/cvsroot/cells/defmodel.lisp 2008/05/21 10:46:52 1.21 +++ /project/cells/cvsroot/cells/defmodel.lisp 2008/06/16 12:38:03 1.22 @@ -185,6 +185,8 @@ (list* `(:default-initargs ,@definitargs) (nreverse class-options))))))))) + + #+test (progn (defclass md-test-super ()()) --- /project/cells/cvsroot/cells/family.lisp 2008/04/23 03:20:09 1.28 +++ /project/cells/cvsroot/cells/family.lisp 2008/06/16 12:38:04 1.29 @@ -26,9 +26,13 @@ ((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name) (.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent) (.value :initform nil :accessor value :initarg :value) + (register? :cell nil :initform nil :initarg :register? :reader register?) (zdbg :initform nil :accessor dbg :initarg :dbg)) ) +(defmethod initialize-instance :after ((self model) &key) + (when (register? self) + (fm-register self))) (defmethod print-cell-object ((md model)) (or (md-name md) :md?)) @@ -92,7 +96,14 @@ (.kids :initform (c-in nil) ;; most useful :owning t :accessor kids - :initarg :kids))) + :initarg :kids) + (registry? :cell nil + :initform nil + :initarg :registry? + :accessor registry?) + (registry :cell nil + :initform nil + :accessor registry))) #+test (let ((c (find-class 'family))) @@ -143,14 +154,11 @@ `(let ((,kid ,self)) (find-prior ,kid (kids (fm-parent ,kid)))))) - -(defun md-be-adopted (self &aux (fm-parent (fm-parent self)) (selftype (type-of self))) - +(defun md-be-adopted (self &aux (fm-parent (fm-parent self)) (selftype (type-of self))) (c-assert self) (c-assert fm-parent) (c-assert (typep fm-parent 'family)) - (trc nil "md be adopted >" :kid self (adopt-ct self) :by fm-parent) (when (plusp (adopt-ct self)) @@ -209,5 +217,45 @@ (declare (ignorable self)) (list ,@slot-defs))) +; --- registry "namespacing" --- + +(defmethod registry? (other) (declare (ignore other)) nil) + +(defmethod initialize-instance :after ((self family) &key) + (when (registry? self) + (setf (registry self) (make-hash-table :test 'eq)))) + +(defmethod fm-register (self &optional (guest self)) + (assert self) + (if (registry? self) + (progn + (trc "fm-registering" (md-name guest) :with self) + (setf (gethash (md-name guest) (registry self)) guest)) + (fm-register (fm-parent self) guest))) + +(defmethod fm-check-out (self &optional (guest self)) + (assert self () "oops ~a ~a ~a" self (fm-parent self) (slot-value self '.fm-parent)) + (if (registry? self) + (remhash (md-name guest) (registry self)) + (bif (p (fm-parent self)) + (fm-check-out p guest) + (break "oops ~a ~a ~a" self (fm-parent self) (slot-value self '.fm-parent))))) + +(defmethod fm-find-registered (id self &optional (must-find? self must-find?-supplied?)) + (or (if (registry? self) + (gethash id (registry self)) + (bwhen (p (fm-parent self)) + (fm-find-registered id p must-find?))) + (when (and must-find? (not must-find?-supplied?)) + (break "fm-find-registered failed seeking ~a starting search at node ~a" id self)))) + +(export! rg? rg!) + +(defmacro rg? (id) + `(fm-find-registered ,id self nil)) + +(defmacro rg! (id) + `(fm-find-registered ,id self)) + \ No newline at end of file --- /project/cells/cvsroot/cells/fm-utilities.lisp 2008/05/24 19:24:05 1.20 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2008/06/16 12:38:04 1.21 @@ -14,7 +14,7 @@ See the Lisp Lesser GNU Public License for more details. -$Header: /project/cells/cvsroot/cells/fm-utilities.lisp,v 1.20 2008/05/24 19:24:05 fgoenninger Exp $ +$Header: /project/cells/cvsroot/cells/fm-utilities.lisp,v 1.21 2008/06/16 12:38:04 ktilton Exp $ |# (in-package :cells) @@ -702,7 +702,6 @@ :global-search global-search)))) (when (and must-find (null match)) (trc "fm-find-one > erroring fm-not-found, in family: " family :seeking md-name :global? global-search) - ;;(inspect family) (setq diag t must-find nil) (fm-traverse family #'matcher :skip-tree skip-tree --- /project/cells/cvsroot/cells/integrity.lisp 2008/04/23 03:20:09 1.22 +++ /project/cells/cvsroot/cells/integrity.lisp 2008/06/16 12:38:04 1.23 @@ -66,6 +66,7 @@ *unfinished-business* *defer-changes*) (trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info) + (when *c-debug* (assert (boundp '*istack*))) (when (or (zerop *data-pulse-id*) (eq opcode :change)) (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info) @@ -77,15 +78,17 @@ (let ((*istack* (list (list opcode defer-info) (list :trigger code) (list :start-dp *data-pulse-id*)))) + (trc "*istack* bound") (handler-case (go-go) - (t (c) + (xcell (c) (if (functionp *c-debug*) (funcall *c-debug* c (nreverse *istack*)) (loop for f in (nreverse *istack*) do (format t "~&istk> ~(~a~) " f) finally (describe c) - (break "integ backtrace: see listener for deets")))))) + (break "integ backtrace: see listener for deets"))))) + (trc "*istack* unbinding")) (go-go))))) (defun ufb-queue (opcode) @@ -163,7 +166,7 @@ ; 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))) - #+x42 (trc "retelling dependenst, one new one being" uqp) + #+xxx (trc "retelling dependenst, one new one being" uqp) (go tell-dependents)) ;--- process client queue ------------------------------ --- /project/cells/cvsroot/cells/link.lisp 2008/03/15 15:18:34 1.26 +++ /project/cells/cvsroot/cells/link.lisp 2008/06/16 12:38:04 1.27 @@ -58,8 +58,7 @@ (defun c-unlink-unused (c &aux (usage (cd-usage c)) (usage-size (array-dimension (cd-usage c) 0)) - (dbg nil)) ;; #+not (and (typep (c-model c) 'mathx::mx-solver-stack) - ;;(eq (c-slot-name c) '.kids)))) + (dbg nil)) (declare (ignorable dbg usage-size)) (when (cd-useds c) (let (rev-pos) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/22 10:11:50 1.46 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/06/16 12:38:04 1.47 @@ -23,9 +23,11 @@ (defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name))) (when (and (not *not-to-be*) (mdead self)) - (trc "md-slot-value passed dead self, returning NIL" self slot-name c) - #-sbcl (inspect self) - (break "see inspector for dead ~a" self) + (unless *stop* + (setf *stop* t) + (trc "md-slot-value passed dead self, returning NIL" self slot-name c) + #-sbcl (inspect self) + (break "see inspector for dead ~a" self)) (return-from md-slot-value nil)) (tagbody retry @@ -47,7 +49,7 @@ ;; (count-it :md-slot-value slot-name) (if c (cell-read c) - (values (bd-slot-value self slot-name) nil))) + (values (slot-value self slot-name) nil))) (defun cell-read (c) (assert (typep c 'cell)) @@ -61,12 +63,6 @@ (when (mdead s) (break "model ~a is dead at ~a" s key))) -;;;(defmethod trcp ((c cell)) -;;; (and *dbg* -;;; (case (c-slot-name c) -;;; (mathx::show-time t) -;;; (ctk::app-time t)))) - (defvar *trc-ensure* nil) (defmethod ensure-value-is-current (c debug-id ensurer) @@ -145,6 +141,7 @@ nil) v))) + (defun calculate-and-set (c) (flet ((body () (when (c-stopped) @@ -154,19 +151,18 @@ #-its-alive! (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) - (c-break "yep" c) - (loop with caller-reiterated - for caller in *call-stack* - until caller-reiterated - do (trc "caller:" caller) - ;; not necessary (pprint (cr-code c)) - (setf caller-reiterated (eq caller c))) + (let () + (inspect c) + (trc "calculating cell:" c (cr-code c)) + (trc "appears-in-call-stack (newest first): " (length *call-stack*)) + (loop for caller in (copy-list *call-stack*) + for n below (length *call-stack*) + do (trc "caller> " caller #+shhh (cr-code caller)) + when (eq caller c) do (loop-finish)))) + (setf *stop* t) (c-break ;; break is problem when testing cells on some CLs "cell ~a midst askers (see above)" c) - (error "see listener for cell rule cycle diagnotics")) + (error 'asker-midst-askers :cell c)) (multiple-value-bind (raw-value propagation-code) (calculate-and-link c) @@ -197,6 +193,20 @@ (funcall (cr-rule c) c) (c-unlink-unused c)))) +#+theabove! +(defun calculate-and-set (c) + (multiple-value-bind (raw-value propagation-code) + (let ((*call-stack* (cons c *call-stack*)) + (*depender* c) + (*defer-changes* t)) + (cd-usage-clear-all c) + (multiple-value-prog1 + (funcall (cr-rule c) c) + (c-unlink-unused c))) + (unless (c-optimized-away-p c) + (md-slot-value-assume c raw-value propagation-code)))) + + ;------------------------------------------------------------- (defun md-slot-makunbound (self slot-name --- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/23 03:20:09 1.22 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/06/16 12:38:04 1.23 @@ -54,7 +54,7 @@ (:method ((self model-object)) (md-quiesce self)) - + (:method :before ((self model-object)) (loop for slot-name in (md-owning-slots self) do (not-to-be (slot-value self slot-name)))) @@ -62,8 +62,7 @@ (:method :around ((self model-object)) (declare (ignorable self)) (let ((*not-to-be* t) - (dbg nil #+not (or (eq (md-name self) :eclm-owner) - (typep self '(or mathx::eclm-2008 clo:ix-form mathx::a1-panel mathx::edit-caret ctk:window))))) + (dbg nil)) (flet ((gok () (unless (eq (md-state self) :eternal-rest) @@ -85,13 +84,15 @@ (mapcar 'type-of (slot-value self '.kids)))) (gok) (when dbg (trc "finished nailing" self)))))))) - + (defun md-quiesce (self) (trc nil "md-quiesce nailing cells" self (type-of self)) (md-map-cells self nil (lambda (c) (trc nil "quiescing" c) (c-assert (not (find c *call-stack*))) - (c-quiesce c)))) + (c-quiesce c))) + (when (register? self) + (fm-check-out self))) (defun c-quiesce (c) (typecase c @@ -112,3 +113,78 @@ ,@initargs :fm-parent (progn (assert self) self))) +(export! self-owned self-owned?) + +(defun (setf self-owned) (new-value self thing) + (if (consp thing) + (loop for e in thing do + (setf (self-owned self e) new-value)) + (if new-value + (progn + (assert (not (find thing (z-owned self)))) + (push thing (z-owned self))) + (progn + (assert (find thing (z-owned self))) + (setf (z-owned self)(delete thing (z-owned self))))))) + +(defun self-owned? (self thing) + (find thing (z-owned self))) + +(defvar *c-d-d*) +(defvar *max-d-d*) + + +(defun count-model (self) + (setf *c-d-d* (make-hash-table :test 'eq) *max-d-d* 0) + (with-metrics (t nil "cells statistics for" self) + (labels ((cc (self) + (count-it :thing) + (count-it :thing (type-of self)) + ;(count-it :thing-type (type-of self)) + (loop for (id . c) in (cells self) + do (count-it :live-cell) + ;(count-it :live-cell id) + + (typecase c + (c-dependent + (count-it :dependent-cell) + (loop repeat (length (c-useds c)) + do (count-it :cell-useds) + (count-it :dep-depth (c-depend-depth c)))) + (otherwise (if (c-inputp c) + (count-it :c-input id) + (count-it :c-unknow)))) + + (loop repeat (length (c-callers c)) + do (count-it :cell-callers))) + + (loop repeat (length (cells-flushed self)) + do (count-it :flushed-cell #+toomuchinfo id)) + + (loop for slot in (md-owning-slots self) do + (loop for k in (let ((sv (SLOT-VALUE self slot))) + (if (listp sv) sv (list sv))) + do (cc k))))) + (cc self)))) + +(defun c-depend-depth (ctop) + (if (null (c-useds ctop)) + 0 + (or (gethash ctop *c-d-d*) + (labels ((cdd (c &optional (depth 1) chain) + (when (and (not (c-useds c)) + (> depth *max-d-d*)) + (setf *max-d-d* depth) + (trc "new dd champ from user" depth :down-to c) + (when (= depth 41) + (trc "end at" (c-slot-name c) :of (type-of (c-model c))) + (loop for c in chain do + (trc "called by" (c-slot-name c) :of (type-of (c-model c)))))) + (setf (gethash c *c-d-d*) + ;(break "c-depend-depth ~a" c) + (progn + ;(trc "dd" c) + (1+ (loop for u in (c-useds c) + maximizing (cdd u (1+ depth) (cons c chain)))))))) + (cdd ctop))))) + \ No newline at end of file --- /project/cells/cvsroot/cells/model-object.lisp 2008/04/23 03:20:09 1.21 +++ /project/cells/cvsroot/cells/model-object.lisp 2008/06/16 12:38:04 1.22 @@ -21,15 +21,17 @@ ;;; --- model-object ---------------------- (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(md-name fm-parent .parent))) + (export '(md-name fm-parent .parent z-owned))) (defclass model-object () ((.md-state :initform :nascent :accessor md-state) ; [nil | :nascent | :alive | :doomed] - (.awaken-on-init-p :initform nil :initarg :awaken-on-init-p :accessor awaken-on-init-p) ; [nil | :nascent | :alive | :doomed] + (.awaken-on-init-p :initform nil :initarg :awaken-on-init-p :accessor awaken-on-init-p) (.cells :initform nil :accessor cells) (.cells-flushed :initform nil :accessor cells-flushed :documentation "cells supplied but un-whenned or optimized-away") - (adopt-ct :initform 0 :accessor adopt-ct))) + (adopt-ct :initform 0 :accessor adopt-ct) + (z-owned :initform nil :accessor z-owned ;; experimental, not yet operative + :documentation "Things such as kids to be taken down when self is taken down"))) (defmethod md-state ((self symbol)) :alive) @@ -202,7 +204,8 @@ (dolist (super (class-precedence-list (find-class class-name)) (setf (md-slot-cell-type class-name slot-name) nil)) (bwhen (entry (assoc slot-name (get (c-class-name super) :cell-types))) - (return-from md-slot-cell-type (setf (md-slot-cell-type class-name slot-name) (cdr entry)))))))) + (return-from md-slot-cell-type + (setf (md-slot-cell-type class-name slot-name) (cdr entry)))))))) (defun (setf md-slot-cell-type) (new-type class-name slot-name) (assert class-name) @@ -216,12 +219,6 @@ do (setf (md-slot-cell-type (class-name c) slot-name) new-type))) (cdar (push (cons slot-name new-type) (get class-name :cell-types))))))) -#+hunh -(md-slot-owning? 'mathx::prb-solver '.kids) - -#+hunh -(cdr (assoc '.value (get 'm-index :indirect-ownings))) - #+test (md-slot-owning? 'm-index '.value) @@ -289,6 +286,10 @@ (defun (setf md-slot-cell) (new-cell self slot-name) (if self ;; not on def-c-variables (bif (entry (assoc slot-name (cells self))) + ; this next branch guessed it would only occur during kid-slotting, + ; before any dependency-ing could have happened, but a math-editor + ; is silently switching between implied-multiplication and mixed numbers + ; while they type and it (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter (declare (ignorable old)) (c-assert (null (c-callers old))) --- /project/cells/cvsroot/cells/propagate.lisp 2008/04/23 03:20:09 1.36 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/06/16 12:38:04 1.37 @@ -58,12 +58,8 @@ (setf (c-pulse c) *data-pulse-id*)) ;--------------- propagate ---------------------------- - - ; n.b. the cell argument may have been optimized away, ; though it is still receiving final processing here. -; - (defparameter *per-cell-handler* nil) --- /project/cells/cvsroot/cells/test-propagation.lisp 2008/02/02 00:09:28 1.2 +++ /project/cells/cvsroot/cells/test-propagation.lisp 2008/06/16 12:38:04 1.3 @@ -22,7 +22,7 @@ (defun tcprop () (untrace) - (test-prep) + (ukt:test-prep) (LET ((box (make-instance 'tcp))) (trc "changing top to 10" *data-pulse-id*) (setf (top box) 10) --- /project/cells/cvsroot/cells/trc-eko.lisp 2008/03/15 15:18:34 1.10 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2008/06/16 12:38:04 1.11 @@ -19,13 +19,12 @@ (in-package :cells) ;----------- trc ------------------------------------------- - +(defparameter *last-trc* (get-internal-real-time)) (defparameter *trcdepth* 0) (defun trcdepth-reset () (setf *trcdepth* 0)) - (defmacro trc (tgt-form &rest os) (if (eql tgt-form 'nil) '(progn) @@ -45,8 +44,23 @@ (count-it :trcfailed))) (count-it :tgtnileval))))))) -(export! brk brkx .bgo) +(defun call-trc (stream s &rest os) + ;(break) + (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) + *trcdepth*) + (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) + (format stream "~&")) + ;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10)) + (setf *last-trc* (get-internal-real-time)) + (format stream "~a" s) + (let (pkwp) + (dolist (o os) + (format stream (if pkwp " ~(~s~)" " ~(~s~)") o) ;; save, used to insert divider, trcx dont like + (setf pkwp (keywordp o)))) + (force-output stream) + (values)) +(export! brk brkx .bgo) (define-symbol-macro .bgo (break "go")) @@ -68,23 +82,8 @@ nconcing (list (intern (format nil "~a" obj) :keyword) obj)))))) -(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*) - (format stream "~&")) - ;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10)) - (setf *last-trc* (get-internal-real-time)) - (format stream "~a" s) - (let (pkwp) - (dolist (o os) - (format stream (if pkwp " ~(~s~)" " ~(~s~)") o) ;; save, used to insert divider, trcx dont like - (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

1 0

[cells-cvs] CVS cells/gui-geometry
by ktilton 16 Jun '08

16 Jun '08

Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv8789/gui-geometry Modified Files: geo-family.lisp Log Message: nothing special --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2008/04/11 09:19:41 1.13 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2008/06/16 12:38:04 1.14 @@ -102,6 +102,7 @@ (^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) @@ -118,23 +119,35 @@ (c? (py-maintain-pt (round (- (l-height .parent) (l-height self)) -2)))) ;--------------- geo.row.flow ---------------------------- -(export! geo-row-flow) +(export! geo-row-flow fixed-col-width ^fixed-col-width ^spacing-hz spacing-hz + max-per-row ^max-per-row) (defmd geo-row-flow (geo-inline) (spacing-hz 0) (spacing-vt 0) (aligned :cell nil) + fixed-col-width + max-per-row (row-flow-layout (c? (loop with max-pb = 0 and pl = 0 and pt = 0 for k in (^kids) - for kpr = (+ pl (l-width k)) + for kn upfrom 0 + for kw = (or (^fixed-col-width) (l-width k)) + for kpr = (+ pl kw) when (unless (= pl 0) - (> kpr (- (l-width self) (outset self)))) do + (if (^max-per-row) + (zerop (mod kn (^max-per-row))) + (> kpr (- (l-width self) (outset self))))) + do + (when (> kpr (- (l-width self) (outset self))) + (trc nil "LR overflow break" kpr :gt (- (l-width self) (outset self)))) + (when (zerop (mod kn (^max-per-row))) + (trc nil "max/row break" kn (^max-per-row) (mod kn (^max-per-row)))) (setf pl 0 pt (+ max-pb (downs (^spacing-vt)))) - + collect (cons pl pt) into pxys - do (incf pl (+ (l-width k)(^spacing-hz))) + do (incf pl (+ kw (^spacing-hz))) (setf max-pb (min max-pb (+ pt (downs (l-height k))))) finally (return (cons max-pb pxys))))) :lb (c? (+ (bif (xys (^row-flow-layout))

1 0

[cells-cvs] CVS Celtk
by ktilton 16 Jun '08

16 Jun '08

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv8311 Modified Files: CELTK.lpr CelloTk.lpr Celtk.lisp composites.lisp demos.lisp lotsa-widgets.lisp run.lisp tk-object.lisp tk-structs.lisp Added Files: notebook.lisp Log Message: Notebook.lisp from Andy and random other recent work --- /project/cells/cvsroot/Celtk/CELTK.lpr 2008/03/23 23:47:42 1.25 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2008/06/16 12:35:52 1.26 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Mar 4, 2008 15:30)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Jun 3, 2008 13:12)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -33,7 +33,8 @@ (make-instance 'module :name "ltktest-ci.lisp") (make-instance 'module :name "lotsa-widgets.lisp") (make-instance 'module :name "demos.lisp") - (make-instance 'module :name "andy-expander.lisp")) + (make-instance 'module :name "andy-expander.lisp") + (make-instance 'module :name "notebook.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\cells") (make-instance 'project-module :name --- /project/cells/cvsroot/Celtk/CelloTk.lpr 2008/01/03 20:23:30 1.3 +++ /project/cells/cvsroot/Celtk/CelloTk.lpr 2008/06/16 12:35:55 1.4 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Mar 11, 2007 7:25)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.1 [Windows] (Apr 15, 2008 21:33)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -33,68 +33,76 @@ :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 - :on-initialization 'celtk::cellogears + :on-initialization 'celtk::test :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/Celtk/Celtk.lisp 2008/01/03 20:23:30 1.42 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2008/06/16 12:35:55 1.43 @@ -16,10 +16,11 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.42 2008/01/03 20:23:30 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.43 2008/06/16 12:35:55 ktilton Exp $ ;(pushnew :tile *features*) ;; frgo, 2007-09-21: Need to do this only when tile actually loaded + (defpackage :celtk (:nicknames "CTK") (:use :common-lisp :utils-kt :cells :cffi) --- /project/cells/cvsroot/Celtk/composites.lisp 2008/04/11 09:23:51 1.28 +++ /project/cells/cvsroot/Celtk/composites.lisp 2008/06/16 12:35:56 1.29 @@ -148,6 +148,7 @@ Actually holds last event code, :focusin or :focusout") on-key-down on-key-up + (post-event-do nil :cell nil) ;; such as pop up alert for user (show-tool-tips? (c-in t)) :width (c?n 800) :height (c?n 600)) @@ -201,6 +202,8 @@ (setf (keyboard-modifiers .tkw) (delete mod (keyboard-modifiers .tkw)))))) + + ;;; Helper function that actually executes decoration change (defun %%do-decoration (widget decoration) (let ((path (path widget))) --- /project/cells/cvsroot/Celtk/demos.lisp 2007/01/29 06:48:41 1.27 +++ /project/cells/cvsroot/Celtk/demos.lisp 2008/06/16 12:35:56 1.28 @@ -87,7 +87,7 @@ (make-instance 'entry :id :entree :fm-parent *parent* - :value (c-in "Boots"))))))))) + :value (c-in "kenzo"))))))))) (defun one-deep-menubar () (mk-menubar --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2008/01/03 20:23:30 1.11 +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2008/06/16 12:35:56 1.12 @@ -37,7 +37,7 @@ (mk-label :text "aaa" :image-files (list (list 'kt (data-pathname "kt69" "gif"))) :height 400 - :width 300 + :width 200 :image (c? (format nil "~(~a.~a~)" (ctk::^path) 'kt))) (assorted-canvas-items) --- /project/cells/cvsroot/Celtk/run.lisp 2008/04/11 09:23:51 1.29 +++ /project/cells/cvsroot/Celtk/run.lisp 2008/06/16 12:35:56 1.30 @@ -29,11 +29,15 @@ (defun run-window (root-class &optional (resetp t) &rest window-initargs) (assert (symbolp root-class)) (setf *tkw* nil) + (when resetp (cells-reset 'tk-user-queue-handler)) (tk-interp-init-ensure) (setf *tki* (Tcl_CreateInterp)) + ;(break "ok?") + ;(deep) + ;; not recommended by Tcl doc (tcl-do-when-idle (get-callback 'tcl-idle-proc) 42) (tk-app-init *tki*) (tk-togl-init *tki*) @@ -53,25 +57,28 @@ (tcl-create-command *tki* "do-key-down" (get-callback 'do-on-key-down) (null-pointer) (null-pointer)) (tcl-create-command *tki* "do-key-up" (get-callback 'do-on-key-up) (null-pointer) (null-pointer)) - + (tcl-create-command *tki* "do-double-click-1" (get-callback 'do-on-double-click-1) (null-pointer) (null-pointer)) + (trc "integ" cells::*within-integrity*) + (with-integrity () ;; w/i somehow ensures tkwin slot gets populated (setf *app* (make-instance 'application :kids (c? (the-kids (setf *tkw* (apply 'make-instance root-class :fm-parent *parent* - window-initargs)))) - ))) + window-initargs))))))) (assert (tkwin *tkw*)) (tk-format `(:fini) "wm deiconify .") - (tk-format-now "bind . <Escape> {destroy .}") + #-its-alive! (tk-format-now "bind . <Escape> {destroy .}") ; ; see above for why we are converting key x-events to application key virtual events: ; (tk-format-now "bind . <KeyPress> {do-key-down %W %K}") (tk-format-now "bind . <KeyRelease> {do-key-up %W %K}") + (tk-format-now "bind . <Double-ButtonPress-1> {do-double-click-1 %W %K; break}") + (block nil (bwhen (ifn (start-up-fn *tkw*)) (funcall ifn *tkw*)) @@ -152,6 +159,9 @@ (otherwise (give-to-window))))) (otherwise (give-to-window))) + (bwhen (do (post-event-do self)) + (setf (post-event-do self) nil) + (funcall do self)) 0))) ;; Our own event loop ! - Use this if it is desirable to do something @@ -220,4 +230,5 @@ ; (defcommand key-down) (defcommand key-up) +(defcommand double-click-1) --- /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/23 23:47:42 1.16 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2008/06/16 12:35:56 1.17 @@ -31,7 +31,9 @@ :documentation "Long story. Tcl C API weak for keypress events. This gets dispatched eventually thanks to DEFCOMMAND") (on-key-up :initarg :on-key-up :accessor on-key-up :initform nil) + (on-double-click-1 :initarg :on-double-click-1 :accessor on-double-click-1 :initform nil) (user-errors :initarg :user-errors :accessor user-errors :initform nil) + (tile? :initform t :cell nil :reader tile? :initarg :tile?)) (:documentation "Root class for widgets and (canvas) items")) --- /project/cells/cvsroot/Celtk/tk-structs.lisp 2008/01/03 20:23:30 1.7 +++ /project/cells/cvsroot/Celtk/tk-structs.lisp 2008/06/16 12:35:56 1.8 @@ -162,6 +162,8 @@ (defun xbe-x (xbe) (xbe x xbe)) (defun xbe-y (xbe) (xbe y xbe)) +(defun xbe-button (xbe) (xbe button xbe)) +(export! xbe-x xbe-y xbe-button xbe) ;; -------------------------------------------- --- /project/cells/cvsroot/Celtk/notebook.lisp 2008/06/16 12:35:56 NONE +++ /project/cells/cvsroot/Celtk/notebook.lisp 2008/06/16 12:35:56 1.1 (in-package :celtk) ;--- n o t e b o o k ---------------------------------------------- #+test (test-nb) (deftk notebook (widget decoration-mixin) () (:tk-spec notebook -height -padding -width) (:default-initargs :id (gentemp "NB") :packing nil)) (defmethod make-tk-instance ((self notebook)) (tk-format `(:make-tk ,self) "ttk::notebook ~a" (^path)) (tk-format `(:pack ,self) "pack ~a -expand yes -fill both" (^path))) (defobserver .kids ((self notebook)) (loop for k in (^kids) do (trc "ttk::notebook adds" k (type-of k) (md-name k) (path k)) (tk-format `(:post-make-tk ,self) "~a add ~a -text ~a" (^path) (path k) (text k)))) ;--- t a b ----------------------------------------------------------- (deftk tab (frame-stack widget) () (:tk-spec tab -state -sticky -padding -text -image) (:default-initargs :id (gentemp "TB"))) (defmacro mk-tab ((&rest inits) &body body) `(make-instance 'tab :fm-parent *parent* ,@inits :kids (c? (the-kids ,@body)))) (defmethod make-tk-instance ((self tab)) (tk-format `(:make-tk ,self) "frame ~a" (^path))) ;--- example usage --------------------------------------------------- (defmd nb-test (window) (kids (c? (the-kids (mk-notebook :width 100 :kids (c? (the-kids (mk-tab (:text "first") (mk-stack ("tab with container") (mk-label :text "hi"))) (mk-tab (:text "second") (mk-label :text "a") (mk-label :text "b"))))))))) (defun test-nb () (test-window 'nb-test))

1 0

[cells-cvs] CVS Celtk/gears
by ktilton 16 Jun '08

16 Jun '08

Update of /project/cells/cvsroot/Celtk/gears In directory clnet:/tmp/cvs-serv8311/gears Modified Files: gears.lpr Log Message: Notebook.lisp from Andy and random other recent work --- /project/cells/cvsroot/Celtk/gears/gears.lpr 2006/10/02 02:56:01 1.2 +++ /project/cells/cvsroot/Celtk/gears/gears.lpr 2008/06/16 12:35:56 1.3 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.1 [Windows] (Apr 15, 2008 21:33)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -17,68 +17,76 @@ :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 - :on-initialization 'gears::nehe-02 + :on-initialization 'gears::gears :on-restart 'do-default-restart) ;; End of Project Definition

1 0

[cells-cvs] CVS cells-ode
by phildebrandt 02 Jun '08

02 Jun '08

Update of /project/cells/cvsroot/cells-ode In directory clnet:/tmp/cvs-serv3184 Modified Files: joints.lisp test-c-ode.lisp Log Message: attach joints by using slots body-1, body-2 --- /project/cells/cvsroot/cells-ode/joints.lisp 2008/06/01 20:26:49 1.4 +++ /project/cells/cvsroot/cells-ode/joints.lisp 2008/06/02 14:12:53 1.5 @@ -25,6 +25,8 @@ (def-ode-model joint () ((joint-type :type int :ode-slot type :read-only t) ; returns one constant +ode:joint-type-...+ (feedback-struct :ode nil :cell nil :initform (foreign-alloc 'ode:joint-feedback)) + (body-1 :ode nil) + (body-2 :ode nil) (force-1 :ode nil) (torque-1 :ode nil) (force-2 :ode nil) @@ -138,6 +140,15 @@ (def-ode-method attach ((self joint) (body1 object) (body2 object))) (def-ode-method set-fixed ((self joint))) (def-ode-method get-body ((self joint) (index int)) object) + +(defobserver body-1 ((self joint)) + (when (and new-value (^body-2)) + (attach self new-value (^body-2)))) + +(defobserver body-2 ((self joint)) + (when (and new-value (^body-1)) + (attach self (^body-1) new-value))) + (defmethod bodies ((self joint)) (list (get-body self 0) (get-body self 1))) --- /project/cells/cvsroot/cells-ode/test-c-ode.lisp 2008/06/01 20:26:49 1.4 +++ /project/cells/cvsroot/cells-ode/test-c-ode.lisp 2008/06/02 14:12:53 1.5 @@ -55,11 +55,12 @@ (make-instance 'body :md-name :body1 :position (c-in #(10 0 .5)) :mass (make-instance 'sphere-mass :mass 30)) (make-instance 'geom-box :md-name :geom1 :size #(1 1 1) :body (obj :body1)) - (make-instance 'body :md-name :body2 :position (c-in #(10 2 .5)) :mass (make-instance 'sphere-mass :mass .1)) - (make-instance 'geom-box :md-name :geom2 :size #(.1 .1 .1) :body (obj :body2)) + (make-instance 'body :md-name :body2 :position (c-in #(10.6 0 .5)) :mass (make-instance 'sphere-mass :mass .5)) + (make-instance 'geom-box :md-name :geom2 :size #(.1 .5 .1) :body (obj :body2)) - (make-instance 'hinge-joint :md-name :joint :axis #(0 1 0) :anchor #(10 1.2 .5)) - (attach (obj :joint) (obj :body1) (obj :body2))) + (make-instance 'hinge-joint :md-name :joint :axis #(1 0 0) :anchor #(10.5 0.5 .5) :body-1 (obj :body1) :body-2 (obj :body2)) + ; (attach (obj :joint) (obj :body1) (obj :body2)) + ) (defun tst-run (&key (diag nil) (step-size .01))

1 0

[cells-cvs] CVS cells-gtk3/cells-gtk
by phildebrandt 02 Jun '08

02 Jun '08

Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv32220/cells-gtk Modified Files: widgets.lisp Log Message: fixed configure event --- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/06/02 13:38:15 1.6 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/06/02 13:50:08 1.7 @@ -36,7 +36,6 @@ (let ((id (apply (symbol-function (new-function-name self)) (new-args self)))) (gtk-object-store id self) - #+libcellsgtk (gtk-signal-connect-swap id "configure-event" (cffi:get-callback 'reshape-widget-handler) :data id) id)))) (callbacks :cell nil :accessor callbacks @@ -352,6 +351,10 @@ (allocated-height self) new-height)))) 0) +#+libcellsgtk +(defmethod md-awaken :after ((self widget)) + (gtk-signal-connect-swap (id self) "configure-event" (cffi:get-callback 'reshape-widget-handler) :data (id self))) + (defmethod focus ((self widget)) (gtk-widget-grab-focus (id self)))

1 0

Jump to page:

2025

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs