From tburdick at common-lisp.net Thu Jul 1 03:48:54 2004 From: tburdick at common-lisp.net (Thomas F. Burdick) Date: Wed, 30 Jun 2004 20:48:54 -0700 Subject: [cells-cvs] CVS update: cell-cultures/asdf-aclproj/asdf-aclproj.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/asdf-aclproj In directory common-lisp.net:/tmp/cvs-serv23904/asdf-aclproj Modified Files: asdf-aclproj.lisp Log Message: Last fixes, Cells-2 works in SBCL and CMUCL now. Date: Wed Jun 30 20:48:54 2004 Author: tburdick Index: cell-cultures/asdf-aclproj/asdf-aclproj.lisp diff -u cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.2 cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.3 --- cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.2 Wed Jun 30 14:02:47 2004 +++ cell-cultures/asdf-aclproj/asdf-aclproj.lisp Wed Jun 30 20:48:54 2004 @@ -31,7 +31,10 @@ (defpackage :asdf-aclproj-user (:use :cl) (:import-from :asdf-aclproj - define-project project module project-module)) + asdf-aclproj::define-project + asdf-aclproj::project + asdf-aclproj::module + asdf-aclproj::project-module)) ;;; ;;; Classes for ASDF @@ -155,10 +158,11 @@ (loop with so-far = () for component in list for depends-on = (reverse so-far) - do (setf (slot-value component 'asdf::in-order-to) + do (setf (slot-value component 'asdf::do-first) + `((asdf:compile-op (asdf:load-op , at depends-on))) + (slot-value component 'asdf::in-order-to) `((asdf:load-op (asdf:load-op , at depends-on)) - (asdf:compile-op (asdf:load-op , at depends-on) - (asdf:compile-op , at depends-on)))) + (asdf:compile-op (asdf:compile-op , at depends-on)))) (push component so-far) finally (return (reverse so-far))))) (setf *project-modules* From tburdick at common-lisp.net Thu Jul 1 03:48:54 2004 From: tburdick at common-lisp.net (Thomas F. Burdick) Date: Wed, 30 Jun 2004 20:48:54 -0700 Subject: [cells-cvs] CVS update: cell-cultures/cells/cells-test.asd Message-ID: Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv23904/cells Modified Files: cells-test.asd Log Message: Last fixes, Cells-2 works in SBCL and CMUCL now. Date: Wed Jun 30 20:48:54 2004 Author: tburdick Index: cell-cultures/cells/cells-test.asd diff -u cell-cultures/cells/cells-test.asd:1.2 cell-cultures/cells/cells-test.asd:1.3 --- cell-cultures/cells/cells-test.asd:1.2 Wed Jun 30 13:56:36 2004 +++ cell-cultures/cells/cells-test.asd Wed Jun 30 20:48:54 2004 @@ -1,8 +1,5 @@ ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;(declaim (optimize (debug 2) (speed 1) (safety 1) (compilation-speed 1))) -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) - (operate 'load-op :asdf-aclproj) (use-package :asdf-aclproj) From tburdick at common-lisp.net Thu Jul 1 03:48:54 2004 From: tburdick at common-lisp.net (Thomas F. Burdick) Date: Wed, 30 Jun 2004 20:48:54 -0700 Subject: [cells-cvs] CVS update: cell-cultures/cells/cells-test/person.lisp cell-cultures/cells/cells-test/test.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cells/cells-test In directory common-lisp.net:/tmp/cvs-serv23904/cells/cells-test Modified Files: person.lisp test.lisp Log Message: Last fixes, Cells-2 works in SBCL and CMUCL now. Date: Wed Jun 30 20:48:54 2004 Author: tburdick Index: cell-cultures/cells/cells-test/person.lisp diff -u cell-cultures/cells/cells-test/person.lisp:1.1 cell-cultures/cells/cells-test/person.lisp:1.2 --- cell-cultures/cells/cells-test/person.lisp:1.1 Sat Jun 26 11:38:37 2004 +++ cell-cultures/cells/cells-test/person.lisp Wed Jun 30 20:48:54 2004 @@ -67,7 +67,7 @@ (cv-test-person-3) (cv-test-person-4) (cv-test-person-5) - (cv-test-talker) + ;; (cv-test-talker) ) (defun cv-test-person-1 () @@ -269,6 +269,7 @@ (setf *stop* nil) t)))) +#+(or) ; FIXME: this test is borked (defun cv-test-talker () ;; ;; make sure cyclic setf is trapped Index: cell-cultures/cells/cells-test/test.lisp diff -u cell-cultures/cells/cells-test/test.lisp:1.1 cell-cultures/cells/cells-test/test.lisp:1.2 --- cell-cultures/cells/cells-test/test.lisp:1.1 Sat Jun 26 11:38:37 2004 +++ cell-cultures/cells/cells-test/test.lisp Wed Jun 30 20:48:54 2004 @@ -30,7 +30,7 @@ (assert ,form ,places ,datum ,@(or args (list `',form))) (format t "~&ok: ~a~&" ',form)))) -(defun testing () +(eval-when (:load-toplevel :compile-toplevel :execute) (pushnew :cells-testing *features*)) (defvar *failed-tests* ()) From ktilton at common-lisp.net Sun Jul 4 18:59:40 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 04 Jul 2004 11:59:40 -0700 Subject: [cells-cvs] CVS update: cell-cultures/config.lisp cell-cultures/build.lisp cell-cultures/cello-config.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures In directory common-lisp.net:/tmp/cvs-serv5472 Modified Files: build.lisp cello-config.lisp Added Files: config.lisp Log Message: Date: Sun Jul 4 11:59:40 2004 Author: ktilton Index: cell-cultures/build.lisp diff -u cell-cultures/build.lisp:1.1 cell-cultures/build.lisp:1.2 --- cell-cultures/build.lisp:1.1 Sat Jun 26 11:38:32 2004 +++ cell-cultures/build.lisp Sun Jul 4 11:59:39 2004 @@ -25,12 +25,15 @@ :type "lisp") *devel-root*)) +;;; --- teach ASDF about LPR files +(let ((d-force t)) + (build-sys d-force "asdf-aclproj")) #-allegro-ide (let ((d-force t)) (pushnew :cells-testing *features*) - (build-sys d-force "cello" "cells") - (build-sys d-force "cello" "cells" "cells-test")) + (build-sys d-force "cells") + (build-sys d-force "cells" "cells-test")) #-allegro-ide (let ((d-force nil)) Index: cell-cultures/cello-config.lisp diff -u cell-cultures/cello-config.lisp:1.1 cell-cultures/cello-config.lisp:1.2 --- cell-cultures/cello-config.lisp:1.1 Sat Jun 26 11:38:32 2004 +++ cell-cultures/cello-config.lisp Sun Jul 4 11:59:39 2004 @@ -1,9 +1,5 @@ (in-package :cl-user) -(defparameter *devel-root* - (make-pathname #+lispworks :host #-lispworks :device "c" - :directory `(:absolute "dvl"))) - (defparameter *cello-directory* (merge-pathnames (make-pathname :directory `(:relative "cello")) From ktilton at common-lisp.net Sun Jul 4 18:59:40 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 04 Jul 2004 11:59:40 -0700 Subject: [cells-cvs] CVS update: cell-cultures/cello/cello.lisp cell-cultures/cello/cello.lpr cell-cultures/cello/image.lisp cell-cultures/cello/ix-geometry.lisp cell-cultures/cello/pick.lisp cell-cultures/cello/cellocore.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cello In directory common-lisp.net:/tmp/cvs-serv5472/cello Modified Files: cello.lpr image.lisp ix-geometry.lisp pick.lisp Added Files: cello.lisp Removed Files: cellocore.lisp Log Message: Date: Sun Jul 4 11:59:40 2004 Author: ktilton Index: cell-cultures/cello/cello.lpr diff -u cell-cultures/cello/cello.lpr:1.1 cell-cultures/cello/cello.lpr:1.2 --- cell-cultures/cello/cello.lpr:1.1 Sat Jun 26 11:38:33 2004 +++ cell-cultures/cello/cello.lpr Sun Jul 4 11:59:40 2004 @@ -4,9 +4,9 @@ (defpackage :cello (:export)) -(define-project :name :cellocore +(define-project :name :cello :application-type (intern "Standard EXE" (find-package :keyword)) - :modules (list (make-instance 'module :name "cellocore.lisp") + :modules (list (make-instance 'module :name "cello.lisp") (make-instance 'module :name "datetime.lisp") (make-instance 'module :name "window-macros.lisp") (make-instance 'module :name "clipping.lisp") @@ -55,11 +55,11 @@ (make-instance 'project-module :name "..\\cl-opengl\\cl-opengl") (make-instance 'project-module :name - "c:\\dvl\\cl-ftgl\\cl-ftgl") + "..\\cl-ftgl\\cl-ftgl") (make-instance 'project-module :name - "c:\\dvl\\cl-magick\\cl-magick") + "..\\cl-magick\\cl-magick") (make-instance 'project-module :name - "c:\\dvl\\cl-openal\\cl-openal")) + "..\\cl-openal\\cl-openal")) :libraries nil :distributed-files nil :project-package-name :cello Index: cell-cultures/cello/image.lisp diff -u cell-cultures/cello/image.lisp:1.1 cell-cultures/cello/image.lisp:1.2 --- cell-cultures/cello/image.lisp:1.1 Sat Jun 26 11:38:33 2004 +++ cell-cultures/cello/image.lisp Sun Jul 4 11:59:40 2004 @@ -32,9 +32,8 @@ (defmethod ogl-dsp-list-prep progn (self) (declare (ignore self)) - (assert (not *listingp*))) + (assert (not *ogl-listing-p*))) -(defparameter *listingp* nil) (defvar *window-rendering*) (defmodel ogl-node () @@ -44,9 +43,9 @@ (let ((display-list-name (or .cache (gl-gen-lists 1))) (*window-rendering* (nearest self window))) - (assert (not *listingp*)) + (assert (not *ogl-listing-p*)) (gl-new-list display-list-name gl_compile) - (let ((*listingp* self) + (let ((*ogl-listing-p* self) *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) (with-metrics (nil nil "(funcall renderer)" self) (ix-paint self))) Index: cell-cultures/cello/ix-geometry.lisp diff -u cell-cultures/cello/ix-geometry.lisp:1.1 cell-cultures/cello/ix-geometry.lisp:1.2 --- cell-cultures/cello/ix-geometry.lisp:1.1 Sat Jun 26 11:38:33 2004 +++ cell-cultures/cello/ix-geometry.lisp Sun Jul 4 11:59:40 2004 @@ -308,20 +308,6 @@ (:center (floor (- (inset-height .parent) (l-height self)) -2)) (:bottom (- (inset-height .parent) (l-height self)))))) - - - - - - - - -(defmacro ^as-low-as-parent () - `(inset-lb (fm-parent self))) - -(defmacro ^as-right-as-kids () - `(^fm-max-kid pr)) - (defmacro ^fill-parent-right (&optional (inset 0)) `(lr-maintain-pr (- (inset-lr .parent) ,inset))) Index: cell-cultures/cello/pick.lisp diff -u cell-cultures/cello/pick.lisp:1.1 cell-cultures/cello/pick.lisp:1.2 --- cell-cultures/cello/pick.lisp:1.1 Sat Jun 26 11:38:33 2004 +++ cell-cultures/cello/pick.lisp Sun Jul 4 11:59:40 2004 @@ -59,7 +59,7 @@ (glu-perspective 45 aspect 0.1 100.0)) ;;OQ: appropriate for ortho? (gl-matrix-mode gl_model-view) - #+not (let ((*listingp* target) + #+not (let ((*ogl-listing-p* target) *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) (with-metrics (nil nil "(funcall renderer)" self) (ix-paint target))) From ktilton at common-lisp.net Sun Jul 4 18:59:41 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 04 Jul 2004 11:59:41 -0700 Subject: [cells-cvs] CVS update: cell-cultures/cellodemo/cellodemo.lpr Message-ID: Update of /project/cells/cvsroot/cell-cultures/cellodemo In directory common-lisp.net:/tmp/cvs-serv5472/cellodemo Modified Files: cellodemo.lpr Log Message: Date: Sun Jul 4 11:59:41 2004 Author: ktilton Index: cell-cultures/cellodemo/cellodemo.lpr diff -u cell-cultures/cellodemo/cellodemo.lpr:1.1 cell-cultures/cellodemo/cellodemo.lpr:1.2 --- cell-cultures/cellodemo/cellodemo.lpr:1.1 Sat Jun 26 11:38:35 2004 +++ cell-cultures/cellodemo/cellodemo.lpr Sun Jul 4 11:59:40 2004 @@ -11,8 +11,8 @@ (make-instance 'module :name "tutor-geometry.lisp") (make-instance 'module :name "light-panel.lisp") (make-instance 'module :name "hedron-render.lisp") - (make-instance 'module :name "hedron-decoration.lisp") - (make-instance 'module :name "do-list.lisp")) + (make-instance 'module :name + "hedron-decoration.lisp")) :projects (list (make-instance 'project-module :name "..\\cello\\cello")) :libraries nil From ktilton at common-lisp.net Sun Jul 4 18:59:42 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 04 Jul 2004 11:59:42 -0700 Subject: [cells-cvs] CVS update: cell-cultures/cells/cell-types.lisp cell-cultures/cells/cells.lisp cell-cultures/cells/constructors.lisp cell-cultures/cells/defpackage.lisp cell-cultures/cells/integrity.lisp cell-cultures/cells/md-slot-value.lisp cell-cultures/cells/model-object.lisp cell-cultures/cells/propagate.lisp cell-cultures/cells/synapse.lisp cell-cultures/cells/cells-test.asd cell-cultures/cells/cells-test.lpr cell-cultures/cells/rif.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv5472/cells Modified Files: cell-types.lisp cells.lisp constructors.lisp defpackage.lisp integrity.lisp md-slot-value.lisp model-object.lisp propagate.lisp synapse.lisp Removed Files: cells-test.asd cells-test.lpr rif.lisp Log Message: Date: Sun Jul 4 11:59:41 2004 Author: ktilton Index: cell-cultures/cells/cell-types.lisp diff -u cell-cultures/cells/cell-types.lisp:1.1 cell-cultures/cells/cell-types.lisp:1.2 --- cell-cultures/cells/cell-types.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/cell-types.lisp Sun Jul 4 11:59:41 2004 @@ -53,8 +53,8 @@ (defstruct (c-ruled (:include cell) (:conc-name cr-)) - (synapses nil :type list) lazy + (code nil :type list) ;; /// feature this out on production build rule) (defun c-optimized-away-p (c) @@ -73,8 +73,8 @@ (defstruct (c-dependent (:include c-ruled) (:conc-name cd-)) + (synapses nil :type list) (useds nil :type list) - (code nil :type list) ;; /// feature this out on production build (usage (make-array *cd-usagect* :element-type 'bit :initial-element 0) :type vector)) Index: cell-cultures/cells/cells.lisp diff -u cell-cultures/cells/cells.lisp:1.2 cell-cultures/cells/cells.lisp:1.3 --- cell-cultures/cells/cells.lisp:1.2 Tue Jun 29 01:58:49 2004 +++ cell-cultures/cells/cells.lisp Sun Jul 4 11:59:41 2004 @@ -112,6 +112,7 @@ (declare (ignorable slot-name self new old old-boundp))) + ; -------- cell conditions (not much used) --------------------------------------------- (define-condition xcell () ;; new 2k0227 Index: cell-cultures/cells/constructors.lisp diff -u cell-cultures/cells/constructors.lisp:1.1 cell-cultures/cells/constructors.lisp:1.2 --- cell-cultures/cells/constructors.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/constructors.lisp Sun Jul 4 11:59:41 2004 @@ -87,7 +87,7 @@ :code ',forms :value-state :unevaluated :rule (c-lambda , at forms) - , at keys)) + , at keys)) (defmacro c-input ((&rest keys) &optional (value nil valued-p)) `(make-cell Index: cell-cultures/cells/defpackage.lisp diff -u cell-cultures/cells/defpackage.lisp:1.3 cell-cultures/cells/defpackage.lisp:1.4 --- cell-cultures/cells/defpackage.lisp:1.3 Wed Jun 30 14:02:47 2004 +++ cell-cultures/cells/defpackage.lisp Sun Jul 4 11:59:41 2004 @@ -38,15 +38,19 @@ #:class-precedence-list #:class-slots #:slot-definition-name ) - - (:export #:cell #:c-input #:c-in #:c-in8 #:c? #:c?8 #:c?_ #:c?? + #+clisp (:import-from #:clos #:class-slots #:class-precedence-list) + #+cmu (:import-from #:pcl #:class-precedence-list #:class-slots + #:slot-definition-name #:true) + #+lispworks (:import-from #:lw #:true) + (:export #:cell #:c-input #:c-in #:c-in8 + #:c-formula #:c? #:c?8 #:c?_ #:c?? #:with-integrity #:with-deference #:without-c-dependency #:self #:.cache #:c-lambda #:.cause #:defmodel #:c-awaken #:def-c-output #:def-c-unchanged-test #:new-value #:old-value #:c... #:make-be #:mkpart #:the-kids #:nsib #:md-value #:^md-value #:.md-value #:kids #:^kids #:.kids - #:cell-reset #:upper #:fm-max #:nearest #:^fm-min-kid #:^fm-max-kid #:mk-kid-slot + #:cell-reset #:upper #:fm-max #:nearest #:fm-min-kid #:fm-max-kid #:mk-kid-slot #:def-kid-slots #:find-prior #:fm-pos #:kid-no #:fm-includes #:fm-ascendant-common #:fm-kid-containing #:fm-find-if #:fm-ascendant-if #:c-abs #:fm-collect-if #:psib #:to-be #:not-to-be #:ssibno #:md-awaken Index: cell-cultures/cells/integrity.lisp diff -u cell-cultures/cells/integrity.lisp:1.1 cell-cultures/cells/integrity.lisp:1.2 --- cell-cultures/cells/integrity.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/integrity.lisp Sun Jul 4 11:59:41 2004 @@ -24,6 +24,7 @@ (defun data-pulse-next (pulse-info) (declare (ignorable pulse-info)) + (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info) (if (< *data-pulse-id* most-positive-fixnum) (incf *data-pulse-id*) (progn @@ -93,7 +94,7 @@ (trc nil "!!!!!!!!!! started new *unfinished-business*" key defer-info) (when (or (zerop *data-pulse-id*) (member opcode '(:setf :makunbound))) - (data-pulse-next defer-info) + (data-pulse-next (cons opcode defer-info)) (trc nil "!!! New pulse, event" *data-pulse-id* defer-info)) (prog1 (funcall action) Index: cell-cultures/cells/md-slot-value.lisp diff -u cell-cultures/cells/md-slot-value.lisp:1.1 cell-cultures/cells/md-slot-value.lisp:1.2 --- cell-cultures/cells/md-slot-value.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/md-slot-value.lisp Sun Jul 4 11:59:41 2004 @@ -54,6 +54,7 @@ (defun c-influenced-by-pulse (c); &aux (ip *data-pulse-id*)) (unless (c-currentp c) (count-it :c-influenced-by-pulse) + (trc c "c-influenced-by-pulse> " c (c-useds c)) (some (lambda (used) (c-value-ensure-current used) (when (and (c-changed used) (> (c-pulse used)(c-pulse c))) Index: cell-cultures/cells/model-object.lisp diff -u cell-cultures/cells/model-object.lisp:1.1 cell-cultures/cells/model-object.lisp:1.2 --- cell-cultures/cells/model-object.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/model-object.lisp Sun Jul 4 11:59:41 2004 @@ -96,15 +96,15 @@ (c-model c) self (c-slot-name c) sn (md-slot-cell self sn) c)) - (if (c-unboundp c) - (progn (trc "unbound cell" (type-of c) c) - (bd-slot-makunbound self sn)) - (setf (slot-value self sn) - (if c-isa-cell + + (if c-isa-cell + (if (c-unboundp c) + (bd-slot-makunbound self sn) + (setf (slot-value self sn) (if (c-inputp c) - (c-value c) - nil) - c)))) + (c-value c) + nil))) + (setf (slot-value self sn) c))) ;------------------ md obj initialization ------------------ Index: cell-cultures/cells/propagate.lisp diff -u cell-cultures/cells/propagate.lisp:1.1 cell-cultures/cells/propagate.lisp:1.2 --- cell-cultures/cells/propagate.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/propagate.lisp Sun Jul 4 11:59:41 2004 @@ -56,15 +56,14 @@ (c-output-slot c (c-slot-name c) (c-model c) (c-value c) prior-value prior-value-supplied))) - (defun c-propagate-to-users (c) (trc nil "c-propagate-to-users > queueing" c :cause *causation*) - (let ((causation (list* c *causation*))) ;; in case deferred + (let ((causation (cons c *causation*))) ;; in case deferred (with-integrity (:user-notify :user-notify c) (let ((*causation* causation)) (trc nil "c-propagate-to-users > notifying users of" c) (dolist (user (c-users c)) - (trc nil "c-propagate-to-users> cause, user, c:" *causation* user c) + (trc user "c-propagate-to-users> *data-pulse-id*, user, c:" *data-pulse-id* user c) (when (c-user-cares user) (c-value-ensure-current user))))))) @@ -89,7 +88,7 @@ (c-output-slot nil slot-name self (bd-slot-value self slot-name) nil nil))) (defun c-output-slot (c slot-name self new-value prior-value prior-value-supplied) - (let ((causation (list* c *causation*))) ;; in case deferred + (let ((causation *causation*)) ;; in case deferred (with-integrity (:c-output-slot :output c) (let ((*causation* causation)) (trc nil "c-output-slot > causation" c *causation* causation) Index: cell-cultures/cells/synapse.lisp diff -u cell-cultures/cells/synapse.lisp:1.1 cell-cultures/cells/synapse.lisp:1.2 --- cell-cultures/cells/synapse.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/synapse.lisp Sun Jul 4 11:59:41 2004 @@ -28,13 +28,13 @@ (defmacro with-synapse (((&rest closure-vars) &key trcp fire-p fire-value) &body body) (declare (ignorable trcp)) (let ((lex-loc-key (gensym "synapse-id"))) - `(let ((synapse (or (cdr (assoc ',lex-loc-key (cr-synapses + `(let ((synapse (or (cdr (assoc ',lex-loc-key (cd-synapses (car *c-calculators*)))) (cdar (push (cons ',lex-loc-key (let (, at closure-vars) (make-synaptic-ruled slot-c (,fire-p ,fire-value) , at body))) - (cr-synapses + (cd-synapses (car *c-calculators*))))))) (progn ;;let ((*c-calculators* (cons synapse *c-calculators*))) (c-value-ensure-current synapse))))) From ktilton at common-lisp.net Sun Jul 4 18:59:43 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 04 Jul 2004 11:59:43 -0700 Subject: [cells-cvs] CVS update: cell-cultures/cells/cells-test/cells-test.asd cell-cultures/cells/cells-test/cells-test.lpr cell-cultures/cells/cells-test/person.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/cells/cells-test In directory common-lisp.net:/tmp/cvs-serv5472/cells/cells-test Modified Files: person.lisp Added Files: cells-test.asd cells-test.lpr Log Message: Date: Sun Jul 4 11:59:42 2004 Author: ktilton Index: cell-cultures/cells/cells-test/cells-test.asd diff -u /dev/null cell-cultures/cells/cells-test/cells-test.asd:1.3 --- /dev/null Sun Jul 4 11:59:43 2004 +++ cell-cultures/cells/cells-test/cells-test.asd Sun Jul 4 11:59:42 2004 @@ -0,0 +1,20 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- + +(operate 'load-op :asdf-aclproj) +(use-package :asdf-aclproj) + +#+(or allegro lispworks cmu mcl clisp cormanlispx sbcl scl) + +(asdf:defsystem :cells-test + :name "cells-test" + :author "Kenny Tilton " + :version "05-Nov-2003" + :maintainer "Kenny Tilton " + :licence "MIT Style" + :description "Cells Regression Test/Documentation" + :long-description "Informatively-commented regression tests for Cells" + :serial t + :components ((lpr-project-file "cells-test"))) + +(defmethod perform :after ((op load-op) (system (eql (find-system :cells-test)))) + (cells::cv-test)) \ No newline at end of file Index: cell-cultures/cells/cells-test/person.lisp diff -u cell-cultures/cells/cells-test/person.lisp:1.2 cell-cultures/cells/cells-test/person.lisp:1.3 --- cell-cultures/cells/cells-test/person.lisp:1.2 Wed Jun 30 20:48:54 2004 +++ cell-cultures/cells/cells-test/person.lisp Sun Jul 4 11:59:42 2004 @@ -287,20 +287,20 @@ (trc "start guarded cyclic") #+not (cv-assert-error - (let ((tk (make-be 'talker))) - (setf (idea tk) "yes") - (cv-assert (string-equal "yes" (words tk))) - (setf (words tk) "no") - (cv-assert (string-equal "no" (idea tk))))) + (let ((tk (make-be 'talker))) + (setf (idea tk) "yes") + (cv-assert (string-equal "yes" (words tk))) + (setf (words tk) "no") + (cv-assert (string-equal "no" (idea tk))))) ;; ;; make sure cells declared to be cyclic are allowed ;; and halt (because after the first cyclic setf the cell in question ;; is being given the same value it already has, and propagation stops. ;; (make-be 'talker8) - #+not (let ((tk (make-be 'talker8))) - (setf (idea8 tk) "yes") - (string-equal "yes" (words8 tk)) - (setf (words8 tk) "no") - (string-equal "no" (idea8 tk))) + #+not (let ((tk (make-be 'talker8))) + (setf (idea8 tk) "yes") + (string-equal "yes" (words8 tk)) + (setf (words8 tk) "no") + (string-equal "no" (idea8 tk))) ) From ktilton at common-lisp.net Sun Jul 4 18:59:44 2004 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 04 Jul 2004 11:59:44 -0700 Subject: [cells-cvs] CVS update: cell-cultures/celtic/menu.lisp cell-cultures/celtic/scrolling.lisp cell-cultures/celtic/button.lisp cell-cultures/celtic/canvas.lisp cell-cultures/celtic/celtic.lisp cell-cultures/celtic/celtic.lpr cell-cultures/celtic/frame.lisp cell-cultures/celtic/textual.lisp cell-cultures/celtic/widget-item.lisp Message-ID: Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv5472/celtic Modified Files: button.lisp canvas.lisp celtic.lisp celtic.lpr frame.lisp textual.lisp widget-item.lisp Added Files: menu.lisp scrolling.lisp Log Message: Date: Sun Jul 4 11:59:43 2004 Author: ktilton Index: cell-cultures/celtic/button.lisp diff -u cell-cultures/celtic/button.lisp:1.3 cell-cultures/celtic/button.lisp:1.4 --- cell-cultures/celtic/button.lisp:1.3 Sun Jun 27 21:25:14 2004 +++ cell-cultures/celtic/button.lisp Sun Jul 4 11:59:43 2004 @@ -26,13 +26,14 @@ ;-------------------------------------------------------------------------- (def-widget button () - (-activebackground -activeforeground -anchor -background - -bitmap -borderwidth -cursor -disabledforeground - -font -foreground -highlightbackground -highlightcolor - -highlightthickness -image -justify -padx -pady -relief -repeatdelay - -repeatinterval -takefocus -text -textvariable -underline -wraplength - (-command nil) - -compound -default -height -overrelief -state -width)) + () + (-activebackground -activeforeground -anchor -background + -bitmap -borderwidth -cursor -disabledforeground + -font -foreground -highlightbackground -highlightcolor + -highlightthickness -image -justify -padx -pady -relief -repeatdelay + -repeatinterval -takefocus -text -textvariable -underline -wraplength + (-command nil) + -compound -default -height -overrelief -state -width)) (defun test-button () (make-be 'button :text (format nil "Time is ~a" (get-internal-real-time)) @@ -45,6 +46,7 @@ ; http://tmml.sourceforge.net/doc/tk/checkbutton.html ; (def-widget checkbutton () + () (-activebackground -activeforeground -anchor -background -bitmap -borderwidth -cursor -disabledforeground -font -foreground -highlightbackground -highlightcolor @@ -62,6 +64,7 @@ (if new-value 1 0)))) (def-widget radiobutton () + () (-activebackground -activeforeground -anchor -background -bitmap -borderwidth -cursor -disabledforeground -font -foreground -highlightbackground -highlightcolor @@ -74,5 +77,6 @@ -tristatevalue (-tk-variable -variable) -width) (:default-initargs :command (lambda (self) - (setf (selection (upper self selector)) self)))) + (setf (selection (upper self selector)) + (value self))))) Index: cell-cultures/celtic/canvas.lisp diff -u cell-cultures/celtic/canvas.lisp:1.1 cell-cultures/celtic/canvas.lisp:1.2 --- cell-cultures/celtic/canvas.lisp:1.1 Sat Jun 26 11:38:38 2004 +++ cell-cultures/celtic/canvas.lisp Sun Jul 4 11:59:43 2004 @@ -22,6 +22,7 @@ (in-package :celtic) (def-widget canvas () + () (-background -borderwidth -cursor -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth -relief Index: cell-cultures/celtic/celtic.lisp diff -u cell-cultures/celtic/celtic.lisp:1.2 cell-cultures/celtic/celtic.lisp:1.3 --- cell-cultures/celtic/celtic.lisp:1.2 Sun Jun 27 16:54:28 2004 +++ cell-cultures/celtic/celtic.lisp Sun Jul 4 11:59:43 2004 @@ -84,11 +84,11 @@ ;;; start wish and set *w* (defun tk-start () #+:sbcl (setf *w* (do-execute "/usr/bin/wish" '("-name" "Cells-LTk"))) - #-:sbcl (setf *w* (do-execute "wish" '("-name" "Cells-LTk")))) + #-:sbcl (setf *w* (do-execute "wish84" '("-name" "Visual Apropos")))) (defun tk-send (text) "send a string to wish" - (when *debug-tk* + (when nil ;; (search "pack " text) ;; *debug-tk* (format t "~&tk-send> ~A~%" text) (force-output)) (format *w* "~A~%" text) @@ -114,11 +114,14 @@ (defvar *callbacks* (make-hash-table :test #'equal)) -(defun register-callback(self callback-id fun - &aux (id (conc$ (path self) "." (down$ callback-id)))) - (format t "~&object ~a registering callback ~a: ~A" self id fun) +(defun register-callback (self callback-id fun + &aux (id (widget-callback-id self callback-id))) + ;;(format t "~&object ~a registering callback ~a: ~A" self :id id) (setf (gethash id *callbacks*) (cons fun self))) +(defun widget-callback-id (self callback-id) + (conc$ (path self) "." (down$ callback-id))) + (defun dispatch-callback(sym args) (let ((func-self (gethash sym *callbacks*))) ;(format t "sym:~S fun:~A~%" sym func-self) @@ -126,18 +129,19 @@ (when (not func-self) (format t "~&callback ~a, type ~a, pkg ~a, not found. known callbacks:" sym (type-of sym) (when (typep sym 'symbol) (symbol-package sym))) - #+shhh (maphash (lambda (key func-self) + (maphash (lambda (key func-self) (declare (ignore func-self)) (format t "~&known callback key ~a, type ~a, pkg ~a" key (type-of key)(when (typep key 'symbol) (symbol-package key)))) *callbacks*)) - (when func-self + (when (car func-self) (apply (car func-self) (cdr func-self) args)))) (defun after (self time func) "Usage: (after self