November 2006 - cells-cvs@common-lisp.net

[cells-cvs] CVS Celtk
by ktilton 13 Nov '06

13 Nov '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv11067 Modified Files: Celtk.lisp composites.lisp lotsa-widgets.lisp menu.lisp run.lisp Log Message: --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/10/02 02:56:01 1.36 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/11/13 05:28:52 1.37 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.36 2006/10/02 02:56:01 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.37 2006/11/13 05:28:52 ktilton Exp $ (defpackage :celtk (:nicknames "CTK") @@ -96,12 +96,12 @@ unless (find (car defer-info) +tk-client-task-priority+) do (error "unknown tk client task type ~a in task: ~a " (car defer-info) defer-info)) - (loop for (nil #+not defer-info . task) in (prog1 - (stable-sort (fifo-data user-q) 'tk-user-queue-sort :key 'car) - (fifo-clear user-q)) + (loop for (defer-info . task) in (prog1 + (stable-sort (fifo-data user-q) 'tk-user-queue-sort :key 'car) + (fifo-clear user-q)) do (trc nil "!!! --- tk-user-queue-handler dispatching" defer-info) - (funcall task))) + (funcall task :user-q defer-info))) (defun tk-format-now (fmt$ &rest fmt-args) (unless (find *tkw* *windows-destroyed*) @@ -111,12 +111,12 @@ ; --- debug stuff --------------------------------- ; - (let ((yes '()) + (let ((yes '("pack")) (no '("font"))) (declare (ignorable yes no)) - (when #+not t (and (or ;; (null yes) - (find-if (lambda (s) (search s tk$)) yes)) - (not (find-if (lambda (s) (search s tk$)) no))) + (when (and (or ;; (null yes) + (find-if (lambda (s) (search s tk$)) yes)) + #+hunh? (not (find-if (lambda (s) (search s tk$)) no))) (format t "~&tk> ~a~%" tk$))) (assert *tki*) --- /project/cells/cvsroot/Celtk/composites.lisp 2006/11/04 20:53:08 1.20 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/11/13 05:28:52 1.21 @@ -97,7 +97,7 @@ (defun app-idle (self) (setf (^app-time) (get-internal-real-time))) -(defmd window (composite-widget decoration-mixin) +(defmd window (toplevel composite-widget decoration-mixin) (title$ (c? (string-capitalize (class-name (class-of self))))) (dictionary (make-hash-table :test 'equalp)) (tkwins (make-hash-table)) @@ -109,12 +109,19 @@ tkfonts-to-load tkfont-sizes-to-load (tkfont-info (tkfont-info-loader)) + start-up-fn + close-fn initial-focus + (focus-state (c-in nil) :documentation "This is about the window having the focus on the desktop, not the key focus. +Actually holds last event code, :focusin or :focusout") on-key-down - on-key-up) + on-key-up + :width (c?n 800) + :height (c?n 600)) -(export! .control-key-p) +(export! .control-key-p .alt-key-p focus-state ^focus-state) (define-symbol-macro .control-key-p (find :control (keyboard-modifiers .tkw))) +(define-symbol-macro .alt-key-p (find :alt (keyboard-modifiers .tkw))) (defmethod make-tk-instance ((self window)) (setf (gethash (^path) (dictionary .tkw)) self)) --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/11/04 20:53:08 1.7 +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/11/13 05:28:52 1.8 @@ -83,10 +83,10 @@ (defun style-by-edit-menu () - (mk-row ("Style by Edit Menu") - (mk-label :text "Four score and seven years ago today" - :wraplength 600 - :tkfont (c? (list + (mk-row ("Style by Edit Menu") + (mk-label :text "Four score and seven years ago today" + :wraplength 600 + :tkfont (c? (list (selection (fm^ :app-font-face)) (selection (fm^ :app-font-size)) (if (fm^v :app-font-italic) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/11/04 20:53:08 1.18 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/11/13 05:28:52 1.19 @@ -213,7 +213,7 @@ :tk-variable (c? (down$ (path (upper self selector)))) :on-command (lambda (self) (declare (ignore key args)) - (trc nil "menu radio button command firing" self (^value) (upper self selector)) + (trc "menu radio button command firing" self (^value) (upper self selector)) (setf (selection (upper self selector)) (^value))))) (defmodel menu-radio-group (selector family) --- /project/cells/cvsroot/Celtk/run.lisp 2006/10/28 18:21:52 1.22 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/11/13 05:28:52 1.23 @@ -25,6 +25,8 @@ (eval-now! (export '(tk-scaling run-window test-window))) + + (defun run-window (root-class &optional (resetp t) &rest window-initargs) (declare (ignorable root-class)) (setf *tkw* nil) @@ -37,7 +39,16 @@ (tk-app-init *tki*) (tk-togl-init *tki*) (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <<trace>> -data $op}") - + (tk-format-now "package require snack") + (tk-format-now "snack::sound s") +;;; (tk-format-now (conc$ "snack::sound s -load " +;;; (snackify-pathname (make-pathname :directory '(:absolute "sounds") +;;; :name "ahem_x" :type "wav") +;;; #+vs (car (directory (make-pathname :directory '(:absolute "sounds"))))))) +;;; (tk-format-now "s play -blocking yes") +;;; (sleep 2) +;;; (tk-format-now "s play") + (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) (null-pointer) (null-pointer)) ;; these next exist because of limitations in the Tcl API. eg, the keypress event does not @@ -65,8 +76,10 @@ ; (tk-format-now "bind . <KeyPress> {do-key-down %W %K}") (tk-format-now "bind . <KeyRelease> {do-key-up %W %K}") - - (tcl-do-one-event-loop)) + (bwhen (ifn (start-up-fn *tkw*)) + (funcall ifn *tkw*)) + (tcl-do-one-event-loop) + ) @@ -93,15 +106,27 @@ (defmethod widget-event-handle ((self window) xe) (let ((*tkw* self)) - (TRC nil "main window event" self *tkw* (xevent-type xe)) + (unless (find (xevent-type xe) '(:MotionNotify)) + (TRC nil "main window event" self *tkw* (xevent-type xe))) (flet ((give-to-window () (bwhen (eh (event-handler *tkw*)) (funcall eh *tkw* xe)))) (case (xevent-type xe) + ((:focusin :focusout) (setf (^focus-state) (xevent-type xe))) ((:MotionNotify :buttonpress) #+shhh (call-dump-event client-data xe)) + (:configurenotify + (setf (^width) (ekx new-width!!! parse-integer (tk-eval "winfo width ."))) + (with-cc :height + (setf (^height) (parse-integer (tk-eval "winfo height .")))) + ) + + (:visibilitynotify + (mathx::a1-snack-off :startup "" 0.8)) (:destroyNotify + (mathx::a1-snack-off :quit "-blocking yes" 0.5) + (let ((*windows-destroyed* (cons *tkw* *windows-destroyed*))) (ensure-destruction *tkw*)))

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 13 Nov '06

13 Nov '06

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv10869/utils-kt Modified Files: utils-kt.lpr Log Message: --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/10/17 21:28:40 1.19 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/11/13 05:28:09 1.20 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- (in-package :cg-user)

1 0

[cells-cvs] CVS cells
by ktilton 13 Nov '06

13 Nov '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv10869 Modified Files: cell-types.lisp cells.lpr constructors.lisp defmodel.lisp family.lisp integrity.lisp md-slot-value.lisp model-object.lisp propagate.lisp slot-utilities.lisp Log Message: --- /project/cells/cvsroot/cells/cell-types.lisp 2006/11/03 13:37:10 1.22 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/11/13 05:28:08 1.23 @@ -44,8 +44,10 @@ ;_____________________ print __________________________________ +#+sigh (defmethod print-object :before ((c cell) stream) - (unless (or *stop* *print-readably*) + (declare (ignorable stream)) + #+shhh (unless (or *stop* *print-readably*) (format stream "[~a~a:" (if (c-inputp c) "i" "?") (cond ((null (c-model c)) #\0) @@ -53,16 +55,19 @@ ((not (c-currentp c)) #\#) (t #\space))))) - (defmethod print-object ((c cell) stream) - (if (or *stop* *print-readably*) - (call-next-method) - (progn - (c-print-value c stream) - (format stream "=~d/~a/~a]" - (c-pulse c) - (symbol-name (or (c-slot-name c) :anoncell)) - (or (and (c-model c)(md-name (c-model c))) :anonmd))))) + (declare (ignorable stream)) + (unless *stop* + (let ((*print-circle* t)) + #+failsafe (format stream "~a/~a" (c-model c)(c-slot-name c)) + (if *print-readably* + (call-next-method) + (progn + (c-print-value c stream) + (format stream "=~d/~a/~a]" + (c-pulse c) + (symbol-name (or (c-slot-name c) :anoncell)) + (bwhen (md (c-model c)) (md-name md) :anonmd))))))) (defmethod trcp :around ((c cell)) (or (c-debug c) @@ -100,13 +105,11 @@ ; ; ;; good q: what does (setf <ephem> 'x) return? historically nil, but...? ; + ;;(trcx bingo-ephem c) (with-integrity (:ephemeral-reset c) (trc nil "!!!!!!!!!!!!!! ephemeral-reset resetting:" c) (md-slot-value-store (c-model c) (c-slot-name c) nil) - (setf (c-value c) nil) - #+notsureaboutthis - (loop for caller in (c-callers c) - do (calculate-and-link caller))))) + (setf (c-value c) nil)))) ; ----------------------------------------------------- @@ -170,5 +173,3 @@ (defmethod c-print-value (c stream) (declare (ignore c stream))) - - --- /project/cells/cvsroot/cells/cells.lpr 2006/11/04 20:52:01 1.23 +++ /project/cells/cvsroot/cells/cells.lpr 2006/11/13 05:28:08 1.24 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- (in-package :cg-user) @@ -23,7 +23,8 @@ (make-instance 'module :name "md-utilities.lisp") (make-instance 'module :name "family.lisp") (make-instance 'module :name "fm-utilities.lisp") - (make-instance 'module :name "family-values.lisp")) + (make-instance 'module :name "family-values.lisp") + (make-instance 'module :name "variables.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\\utils-kt")) :libraries nil --- /project/cells/cvsroot/cells/constructors.lisp 2006/11/03 13:37:10 1.12 +++ /project/cells/cvsroot/cells/constructors.lisp 2006/11/13 05:28:08 1.13 @@ -92,7 +92,7 @@ :lazy :until-asked :rule (c-lambda ,@body))) -(export! c?dbg c_?dbg) +(export! c?dbg c_?dbg c-input-dbg) (defmacro c_?dbg (&body body) "Lazy until asked, then eagerly propagating" --- /project/cells/cvsroot/cells/defmodel.lisp 2006/10/02 02:38:31 1.10 +++ /project/cells/cvsroot/cells/defmodel.lisp 2006/11/13 05:28:08 1.11 @@ -118,18 +118,18 @@ (find-class ',class)))) (defun defmd-canonicalize-slot (slotname - &key - (cell nil cell-p) + &key + (cell nil cell-p) (owning nil owning-p) (type nil type-p) - (initform nil initform-p) - (initarg (intern (symbol-name slotname) :keyword)) - (documentation nil documentation-p) - (unchanged-if nil unchanged-if-p) - (reader slotname reader-p) - (writer `(setf ,slotname) writer-p) - (accessor slotname accessor-p) - (allocation nil allocation-p)) + (initform nil initform-p) + (initarg (intern (symbol-name slotname) :keyword)) + (documentation nil documentation-p) + (unchanged-if nil unchanged-if-p) + (reader slotname reader-p) + (writer `(setf ,slotname) writer-p) + (accessor slotname accessor-p) + (allocation nil allocation-p)) (list* slotname :initarg initarg (append (when cell-p (list :cell cell)) --- /project/cells/cvsroot/cells/family.lisp 2006/11/04 20:52:01 1.16 +++ /project/cells/cvsroot/cells/family.lisp 2006/11/13 05:28:08 1.17 @@ -41,6 +41,17 @@ (define-symbol-macro .parent (fm-parent self)) +(defmethod md-name (other) + (trc "yep other md-name" other (type-of other)) + other) + +(defmethod md-name ((nada null)) + (unless (c-stopped) + (c-stop :md-name-on-null) + (break "md-name called on nil"))) + +(defmethod md-name ((sym symbol)) sym) + (defmethod shared-initialize :around ((self model) slotnames &rest initargs &key fm-parent) (declare (ignorable initargs slotnames fm-parent)) @@ -189,12 +200,5 @@ (declare (ignorable self)) (list ,@slot-defs))) -(defmethod md-name (other) - (trc "yep other md-name" other (type-of other)) - other) -(defmethod md-name ((nada null)) - (unless (c-stopped) - (c-stop :md-name-on-null) - (break "md-name called on nil"))) --- /project/cells/cvsroot/cells/integrity.lisp 2006/11/04 20:52:01 1.15 +++ /project/cells/cvsroot/cells/integrity.lisp 2006/11/13 05:28:08 1.16 @@ -24,24 +24,22 @@ :ephemeral-reset :change)) -(defmacro with-integrity ((&optional opcode defer-info) &rest body) +(defmacro with-integrity ((&optional opcode defer-info debug) &rest body) (when opcode (assert (find opcode *ufb-opcodes*) () "Invalid second value to with-integrity: ~a" opcode)) - `(call-with-integrity ,opcode ,defer-info (lambda () ,@body))) + `(call-with-integrity ,opcode ,defer-info (lambda (opcode defer-info) + (declare (ignorable opcode defer-info)) + ,(when debug + `(trc "integrity action entry" opcode defer-info ',body)) + ,@body))) -(export! with-c-change with-c-changes) +(export! with-cc) -(defmacro with-c-change (id &body body) +(defmacro with-cc (id &body body) `(with-integrity (:change ,id) ,@body)) -(defmacro with-c-changes (id &rest change-forms) - `(with-c-change ,id - ,(car change-forms) - ,(when (cdr change-forms) - `(with-c-changes ,id ,@(cdr change-forms))))) - (defun integrity-managed-p () *within-integrity*) @@ -51,7 +49,7 @@ (if *within-integrity* (if opcode (ufb-add opcode (cons defer-info action)) - (funcall action)) + (funcall action opcode defer-info)) (let ((*within-integrity* t) *unfinished-business* *defer-changes*) @@ -62,7 +60,7 @@ (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info) (data-pulse-next (cons opcode defer-info)))) (prog1 - (funcall action) + (funcall action opcode defer-info) (finish-business))))) (defun ufb-queue (opcode) @@ -87,10 +85,10 @@ (ufb-queue op-or-q) op-or-q))) (trc nil "just do it doing" op-or-q) - (loop for (nil . task) = (fifo-pop q) + (loop for (defer-info . task) = (fifo-pop q) while task do (trc nil "unfin task is" opcode task) - (funcall task))) + (funcall task op-or-q defer-info))) (defun finish-business () (when *stop* (return-from finish-business)) @@ -169,7 +167,7 @@ (destructuring-bind (defer-info . task-fn) task-info (trc nil "finbiz: deferred state change" defer-info) (data-pulse-next (list :finbiz defer-info)) - (funcall task-fn) + (funcall task-fn :change defer-info) ; ; to finish this state change we could recursively call (finish-business), but ; a goto let's us not use the stack. Someday I envision code that keeps on --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/11/03 13:37:10 1.31 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/11/13 05:28:08 1.32 @@ -40,12 +40,16 @@ ;; (count-it :md-slot-value slot-name) (if c - (prog1 - (with-integrity () - (ensure-value-is-current c :mdsv nil)) - (when (car *call-stack*) - (record-caller c))) + (cell-read c) (values (bd-slot-value self slot-name) nil))) + +(defun cell-read (c) + (assert (typep c 'cell)) + (prog1 + (with-integrity () + (ensure-value-is-current c :c-read nil)) + (when (car *call-stack*) + (record-caller c)))) (defun chk (s &optional (key 'anon)) (when (eq :eternal-rest (md-state s)) @@ -56,12 +60,12 @@ (count-it :ensure-value-is-current) (trc nil "ensure-value-is-current > entry" c :now-pulse *data-pulse-id* debug-id caller) - (when (eq :eternal-rest (md-state (c-model c))) + (when (and (not (symbolp (c-model c)))(eq :eternal-rest (md-state (c-model c)))) (break "model ~a of cell ~a is dead" (c-model c) c)) (cond ((c-currentp c) - (trc nil "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete + (trc c "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete ;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete ;; ((and (c-inputp c) @@ -112,11 +116,11 @@ (trc "calculating cell ~a appears in call stack: ~a" c x stack ))) (setf *stop* t) (c-break "yep" c) - #+not (loop with caller-reiterated - for caller in *call-stack* - until caller-reiterated - do (trc "caller:" caller) - (pprint (cr-code 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))) (c-break ;; break is problem when testing cells on some CLs "cell ~a midst askers (see above)" c) @@ -138,6 +142,7 @@ (let ((*call-stack* (cons c *call-stack*)) (*defer-changes* t)) (assert (typep c 'c-ruled)) + (trc nil "calculate-and-link" c) (cd-usage-clear-all c) (multiple-value-prog1 (funcall (cr-rule c) c) --- /project/cells/cvsroot/cells/model-object.lisp 2006/10/17 21:28:39 1.13 +++ /project/cells/cvsroot/cells/model-object.lisp 2006/11/13 05:28:08 1.14 @@ -31,6 +31,8 @@ :documentation "cells supplied but un-whenned or optimized-away") (adopt-ct :initform 0 :accessor adopt-ct))) +(defmethod md-state ((self symbol)) + :alive) ;;; --- md obj initialization ------------------ (defmethod shared-initialize :after ((self model-object) slotnames @@ -67,31 +69,34 @@ (md-awaken self))) )) - - -(defun md-install-cell (self sn c &aux (c-isa-cell (typep c 'cell))) +(defun md-install-cell (self slot-name c &aux (c-isa-cell (typep c 'cell))) ; ; iff cell, init and move into dictionary ; (when c-isa-cell (count-it :md-install-cell) - (setf (c-model c) self - (c-slot-name c) sn - (md-slot-cell self sn) c)) + (c-slot-name c) slot-name + (md-slot-cell self slot-name) c)) ; ; now have the slot really be the slot ; (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))) - (setf (slot-value self sn) c))) ;; (in which case "c" is not actually a cell) - + (bd-slot-makunbound self slot-name) + (if self + (setf (slot-value self slot-name) + (when (c-inputp c) (c-value c))) + (setf (symbol-value slot-name) + (when (c-inputp c) (c-value c))))) + ;; note that in this else branch "c" is a misnomer since + ;; the value is not actually a cell + (if self + (setf (slot-value self slot-name) c) + (setf (symbol-value slot-name) c)))) + + ;;; --- awaken -------- ; ; -- do initial evaluation of all ruled slots @@ -163,44 +168,61 @@ (slot-value self slot)) (defmethod md-slot-cell (self slot-name) - (cdr (assoc slot-name (cells self)))) + (if self + (cdr (assoc slot-name (cells self))) + (get slot-name 'cell))) (defun md-slot-cell-type (class-name slot-name) - (bif (entry (assoc slot-name (get class-name :cell-types))) - (cdr entry) - (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))))))) + (assert class-name) + (if (eq class-name 'null) + (get slot-name :cell-type) + (bif (entry (assoc slot-name (get class-name :cell-types))) + (cdr entry) + (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)))))))) (defun (setf md-slot-cell-type) (new-type class-name slot-name) - (let ((entry (assoc slot-name (get class-name :cell-types)))) - (if entry - (progn - (setf (cdr entry) new-type) - (loop for c in (class-direct-subclasses (find-class class-name)) + (assert class-name) + (if (eq class-name 'null) ;; not def-c-variable + (setf (get slot-name :cell-type) new-type) + (let ((entry (assoc slot-name (get class-name :cell-types)))) + (if entry + (progn + (setf (cdr entry) new-type) + (loop for c in (class-direct-subclasses (find-class class-name)) do (setf (md-slot-cell-type (class-name c) slot-name) new-type))) - (push (cons slot-name new-type) (get class-name :cell-types))))) + (push (cons slot-name new-type) (get class-name :cell-types)))))) (defun md-slot-owning (class-name slot-name) - (bif (entry (assoc slot-name (get class-name :ownings))) - (cdr entry) - (dolist (super (class-precedence-list (find-class class-name))) - (bwhen (entry (assoc slot-name (get (c-class-name super) :ownings))) - (return (setf (md-slot-owning class-name slot-name) (cdr entry))))))) + (assert class-name) + (if (eq class-name 'null) + (get slot-name :owning) + (bif (entry (assoc slot-name (get class-name :ownings))) + (cdr entry) + (dolist (super (class-precedence-list (find-class class-name))) + (bwhen (entry (assoc slot-name (get (c-class-name super) :ownings))) + (return (setf (md-slot-owning class-name slot-name) (cdr entry)))))))) (defun (setf md-slot-owning) (value class-name slot-name) - (let ((entry (assoc slot-name (get class-name :ownings)))) - (if entry - (progn - (setf (cdr entry) value) - (loop for c in (class-direct-subclasses (find-class class-name)) + (assert class-name) + (if (eq class-name 'null) + (setf (get slot-name :owning) value) + + (let ((entry (assoc slot-name (get class-name :ownings)))) + (if entry + (progn + (setf (cdr entry) value) + (loop for c in (class-direct-subclasses (find-class class-name)) do (setf (md-slot-owning (class-name c) slot-name) value))) - (push (cons slot-name value) (get class-name :ownings))))) + (push (cons slot-name value) (get class-name :ownings)))))) -(defmethod md-slot-value-store ((self model-object) slot-name new-value) - (trc nil "md-slot-value-store" slot-name new-value) - (setf (slot-value self slot-name) new-value)) +(defun md-slot-value-store (self slot-name new-value) + (trc nil "md-slot-value-store" self slot-name new-value) + (if self + (setf (slot-value self slot-name) new-value) + (setf (symbol-value slot-name) new-value))) (defun md-slot-cell-flushed (self slot-name) (cdr (assoc slot-name (cells-flushed self)))) @@ -220,17 +242,19 @@ (defmethod cell-when (other) (declare (ignorable other)) nil) (defun (setf md-slot-cell) (new-cell self slot-name) - (bif (entry (assoc slot-name (cells self))) - (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter - (declare (ignorable old)) - (c-assert (null (c-callers old))) - (c-assert (null (cd-useds old))) - (trc nil "replacing in model .cells" old new-cell self) - (rplacd entry new-cell)) - (progn - (trc nil "adding to model .cells" new-cell self) - (push (cons slot-name new-cell) - (cells self))))) + (if self ;; not on def-c-variables + (bif (entry (assoc slot-name (cells self))) + (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter + (declare (ignorable old)) + (c-assert (null (c-callers old))) + (c-assert (null (cd-useds old))) + (trc nil "replacing in model .cells" old new-cell self) + (rplacd entry new-cell)) + (progn + (trc nil "adding to model .cells" new-cell self) + (push (cons slot-name new-cell) + (cells self)))) + (setf (get slot-name 'cell) new-cell))) (defun md-map-cells (self type celldo) (map type (lambda (cell-entry) --- /project/cells/cvsroot/cells/propagate.lisp 2006/11/03 13:37:10 1.25 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/11/13 05:28:08 1.26 @@ -73,7 +73,7 @@ (when *stop* (princ #\.)(princ #\!) (return-from c-propagate)) - (trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)) c) + (trc c "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)) c) (trc nil "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c) (when *c-debug* (when (> *c-prop-depth* 250) --- /project/cells/cvsroot/cells/slot-utilities.lisp 2006/05/20 06:32:19 1.3 +++ /project/cells/cvsroot/cells/slot-utilities.lisp 2006/11/13 05:28:08 1.4 @@ -84,7 +84,9 @@ (slot-boundp self slot-name)) (defun bd-slot-makunbound (self slot-name) - (slot-makunbound self slot-name)) + (if slot-name ;; not in def-c-variable + (slot-makunbound self slot-name) + (makunbound self))) #| sample incf (defmethod c-value-incf ((base fpoint) delta)

1 0

[cells-cvs] CVS cells/gui-geometry
by ktilton 13 Nov '06

13 Nov '06

Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv10869/gui-geometry Modified Files: geo-family.lisp geometer.lisp gui-geometry.lpr Log Message: --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/11/03 13:37:12 1.10 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/11/13 05:28:08 1.11 @@ -30,19 +30,23 @@ (:horizontal :top)))) (spacing :initarg :spacing :initform 0 :accessor spacing)) (:default-initargs - :lr (c? (+ (^outset) + :lr (c? (if (^collapsed) + (^lr-width 0) + (+ (^outset) + (ecase (orientation self) + (:vertical (loop for k in (^kids) + maximizing (l-width k))) + (:horizontal (bif (lk (last1 (^kids))) + (pr lk) 0)))))) + :lb (c? (if (^collapsed) + (^lb-height 0) + (+ (- (^outset)) (ecase (orientation self) (:vertical (loop for k in (^kids) - maximizing (l-width k))) - (:horizontal (bif (lk (last1 (^kids))) - (pr lk) 0))))) - :lb (c? (+ (- (^outset)) - (ecase (orientation self) - (:vertical (loop for k in (^kids) unless (collapsed k) minimizing (pb k))) - (:horizontal (downs (loop for k in (^kids) - maximizing (l-height k))))))) + (:horizontal (downs (loop for k in (^kids) + maximizing (l-height k)))))))) :kid-slots (lambda (self) (ecase (orientation .parent) (:vertical (list @@ -54,9 +58,10 @@ (:horizontal (list (mk-kid-slot (py :if-missing t) (c? (py-self-centered self (justify .parent)))) - (mk-kid-slot (px) + (mk-kid-slot (px :if-missing t) (c? (px-maintain-pl - (^prior-sib-pr self (spacing .parent))))))))))) + (^prior-sib-pr self (spacing .parent))))))))) + )) (defmodel geo-inline-lazy (geo-zero-tl) ((orientation :initarg :orientation :initform nil :accessor orientation --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/10/28 18:20:54 1.11 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/11/13 05:28:08 1.12 @@ -17,7 +17,7 @@ (in-package #:gui-geometry) (eval-now! - (export '(outset ^outset mkv2 g-offset g-offset-h g-offset-v collapsed ^collapsed))) + (export '(outset ^outset mkv2 g-offset g-offset-h g-offset-v collapsed ^collapsed inset ^inset))) (defmd geometer () px py ll lt lr lb @@ -59,6 +59,8 @@ (mkr (ll geo) (lt geo) (lr geo) (lb geo))) ;---------- gOffset ------------------- + +(export! offset-within) ; (defun offset-within (inner outer &optional dbg) (declare (ignorable dbg)) --- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/10/28 18:20:54 1.6 +++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/11/13 05:28:08 1.7 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Oct 17, 2006 12:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- (in-package :cg-user)

1 0

[cells-cvs] CVS Celtk
by ktilton 04 Nov '06

04 Nov '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv31024 Modified Files: button.lisp composites.lisp demos.lisp entry.lisp fileevent.lisp lotsa-widgets.lisp ltktest-ci.lisp menu.lisp multichoice.lisp togl.lisp Log Message: New "lite" versions of Celtk without all the Tk widgets, for PureCello --- /project/cells/cvsroot/Celtk/button.lisp 2006/11/03 13:37:50 1.6 +++ /project/cells/cvsroot/Celtk/button.lisp 2006/11/04 20:53:08 1.7 @@ -66,12 +66,12 @@ -offvalue -onvalue) (:default-initargs :id (gentemp "CK") - :md-value (c-in nil) + :value (c-in nil) :tk-variable (c? (^path)) :on-command (lambda (self) - (setf (^md-value) (not (^md-value)))))) + (setf (^value) (not (^value)))))) -(defobserver .md-value ((self checkbutton)) +(defobserver .value ((self checkbutton)) (tk-format `(:variable ,self) "set ~(~a~) ~a" (path self) (if new-value 1 0))) ; --- radiobutton ------------------------------------- --- /project/cells/cvsroot/Celtk/composites.lisp 2006/10/02 02:56:01 1.19 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/11/04 20:53:08 1.20 @@ -113,6 +113,9 @@ on-key-down on-key-up) +(export! .control-key-p) +(define-symbol-macro .control-key-p (find :control (keyboard-modifiers .tkw))) + (defmethod make-tk-instance ((self window)) (setf (gethash (^path) (dictionary .tkw)) self)) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/11/03 13:37:50 1.25 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/11/04 20:53:08 1.26 @@ -26,7 +26,7 @@ :kids (c? (the-kids (mk-stack ("stack" :packing (c?pack-self "-side bottom") :relief 'ridge) (mk-entry :id :my-entry - :md-value (c-in "abc")) + :value (c-in "abc")) (mk-row ( "row" #| :packing (c?pack-self "-side bottom") |# :relief 'ridge) (mk-label :text (c? (format nil "selection: ~a" (selection (fm^ :my-selector))))) (mk-label :text "Labeltext") @@ -81,13 +81,13 @@ :kids (c? (the-kids (mk-text-widget :id :my-text - :md-value (c?n "[bzbzbzbz]") + :value (c?n "[bzbzbzbz]") :height 8 :width 25) (make-instance 'entry :id :entree :fm-parent *parent* - :md-value (c-in "Boots")) + :value (c-in "Boots")) ;;; (make-instance 'button ;;; :fm-parent *parent* ;;; :text "read" @@ -100,7 +100,7 @@ ;;; (trc "we got scale callbacks" self (parse-integer value))))) ;;; (mk-spinbox ;;; :id :spin-pkg - ;;; :md-value (c-in "cells") ;;(cells::c?n "cells") + ;;; :value (c-in "cells") ;;(cells::c?n "cells") ;;; :tk-values (mapcar 'down$ ;;; (sort (mapcar 'package-name ;;; (list-all-packages)) @@ -135,7 +135,7 @@ (mk-stack (:packing (c?pack-self)) (mk-spinbox :id :spin-pkg - :md-value (c-in "cells") ;;(cells::c?n "cells") + :value (c-in "cells") ;;(cells::c?n "cells") :tk-values (mapcar 'down$ (sort (mapcar 'package-name (list-all-packages)) @@ -145,7 +145,7 @@ :list-height 6 :list-item-keys (c? (trc "enter item keys" self (fm^ :spin-pkg)) (let* ((spinner (fm^ :spin-pkg)) - (item (when spinner (md-value spinner))) + (item (when spinner (value spinner))) (pkg (find-package (string-upcase item)))) (when pkg (loop for sym being the symbols in pkg @@ -156,7 +156,7 @@ :list-item-factory (lambda (sym) (make-instance 'listbox-item :fm-parent *parent* - :md-value sym + :value sym :item-text (down$ (symbol-name sym))))) (mk-label :text (c? (selection (fm^ :spinpkg-sym-list))))))))) @@ -194,16 +194,16 @@ (defmodel font-view (frame-stack) () (:default-initargs - :md-value (c? (tk-eval-list "font families")) + :value (c? (tk-eval-list "font families")) :pady 2 :padx 4 :packing-side 'left :layout-anchor 'nw :kids (c? (the-kids (mk-spinbox :id :font-face - :md-value (c-in (car (^md-value))) - :tk-values (c? (md-value .parent))) + :value (c-in (car (^value))) + :tk-values (c? (value .parent))) (mk-scale :id :font-size - :md-value (c-in 14) + :value (c-in 14) :tk-label "Font Size" :from 7 :to 24 :orient 'horizontal) @@ -211,8 +211,8 @@ :text "Four score seven years ago today" :wraplength 600 :tkfont (c? (list ;; format nil "{{~{~a~^ ~}} ~a}" ;; eg, {{wp greek century} 24} - (md-value (fm^ :font-face)) - (md-value (fm^ :font-size))))))))) + (value (fm^ :font-face)) + (value (fm^ :font-size))))))))) #| 06-02-14 following stuff not resurrected after latest revisions to Celtk @@ -224,12 +224,12 @@ (defmodel file-open (toplevel) () (:default-initargs - :md-value (c? (directory "\\windows\\fonts\\*.ttf")) + :value (c? (directory "\\windows\\fonts\\*.ttf")) :pady 2 :padx 4 :kids (c? (the-kids (mk-spinbox :id :font-face - :md-value (c-in (car (^md-value))) - :tk-values (c? (mapcar 'pathname-name (md-value .parent)))) + :value (c-in (car (^value))) + :tk-values (c? (mapcar 'pathname-name (value .parent)))) (mk-button-ex ("Open" (progn (tk-format `(:destroy ,self) "destroy ~a" (path (upper self toplevel))) (not-to-be (upper self toplevel)))) --- /project/cells/cvsroot/Celtk/entry.lisp 2006/11/03 13:37:50 1.16 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/11/04 20:53:08 1.17 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.16 2006/11/03 13:37:50 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.17 2006/11/04 20:53:08 ktilton Exp $ (in-package :Celtk) @@ -51,10 +51,10 @@ ;; assuming write op, but data field shows that (let ((new-value (tcl-get-var *tki* (^path) (var-flags :TCL-NAMESPACE-ONLY)))) - (unless (string= new-value (^md-value)) - (setf (^md-value) new-value)))))))) + (unless (string= new-value (^value)) + (setf (^value) new-value)))))))) - :md-value (c-in ""))) + :value (c-in ""))) (defmethod md-awaken :after ((self entry)) ;; move this to a traces slot on widget (with-integrity (:client `(:trace ,self)) @@ -63,10 +63,10 @@ ;;; /// this next replicates the handling of tk-mirror-variable because ;;; those leverage the COMMAND mechanism, which entry lacks ;; -(defobserver .md-value ((self entry)) +(defobserver .value ((self entry)) (when new-value (unless (string= new-value old-value) - (trc nil "md-value output" self new-value) + (trc nil "value output" self new-value) (tcl-set-var *tki* (^path) new-value (var-flags :TCL-NAMESPACE-ONLY))))) (deftk text-widget (widget) @@ -86,7 +86,7 @@ -undo -width -wrap) (:default-initargs :id (gentemp "TXT") - :md-value (c-in "<your text here>") + :value (c-in "<your text here>") :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) :modified (c-in nil) @@ -101,10 +101,10 @@ )))) (defmethod clear ((self text-widget)) - (setf (md-value self) nil)) + (setf (value self) nil)) -(defobserver .md-value ((self text-widget)) - (trc nil "md-value output" self new-value) +(defobserver .value ((self text-widget)) + (trc nil "value output" self new-value) (with-integrity (:client `(:variable ,self)) (tk-format-now "~a delete 1.0 end" (^path)) (when (plusp (length new-value)) --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/06/03 12:12:19 1.8 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2006/11/04 20:53:08 1.9 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.8 2006/06/03 12:12:19 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.9 2006/11/04 20:53:08 ktilton Exp $ ;;; --------------------------------------------------------------------------- ;;; =========================================================================== @@ -543,7 +543,7 @@ (let ((data (read-line stream nil nil nil))) (trc "*** USRF: data = " data) (if data - (setf (md-value (fm-other :receive-window)) data) + (setf (value (fm-other :receive-window)) data) (funcall (^eof-fn) self))))) (defmodel fileevent-test-window (window) @@ -555,7 +555,7 @@ :pady 10) (mk-text-widget :id :receive-window ;:state 'disabled - :md-value (c-in "") + :value (c-in "") :height 10 :width 80 :borderwidth 2 --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/11/03 13:37:50 1.6 +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2006/11/04 20:53:08 1.7 @@ -46,7 +46,7 @@ (mk-stack () (mk-text-widget :id :my-text - :md-value (c?n "hello, world") + :value (c?n "hello, world") :height 8 :width 25) @@ -60,14 +60,14 @@ (mk-row () (mk-checkbutton :id :check-me :text "Check Me" - :md-value (c-in t)) + :value (c-in t)) (mk-label :text (c? (if (fm^v :check-me) "checked" "unchecked")))) (mk-row () (mk-button-ex ("Time now?" (setf (fm^v :push-time) (get-universal-time)))) - (mk-label :text (c? (time-of-day (^md-value))) + (mk-label :text (c? (time-of-day (^value))) :id :push-time - :md-value (c-in (get-universal-time)))) + :value (c-in (get-universal-time)))) (style-by-edit-menu) @@ -98,7 +98,7 @@ (mk-stack () (mk-spinbox :id :spin-pkg - :md-value (cells::c?n "cells") + :value (cells::c?n "cells") :tk-values (mapcar 'down$ (sort (mapcar 'package-name (list-all-packages)) @@ -107,7 +107,7 @@ :id :spinpkg-sym-list :list-height 6 :list-item-keys (c? (let* ((spinner (fm^ :spin-pkg)) - (item (when spinner (md-value spinner))) + (item (when spinner (value spinner))) (pkg (find-package (string-upcase item)))) (when pkg (loop for sym being the symbols in pkg @@ -118,7 +118,7 @@ :list-item-factory (lambda (sym) (make-instance 'listbox-item :fm-parent *parent* - :md-value sym + :value sym :item-text (down$ (symbol-name sym))))))) (defun duelling-scrolled-lists () @@ -131,7 +131,7 @@ :list-item-factory (lambda (pkg) (make-instance 'listbox-item :fm-parent *parent* - :md-value pkg + :value pkg :item-text (down$ (package-name pkg))))) (mk-scrolled-list :id :pkg-sym-list @@ -142,7 +142,7 @@ collecting sym))) :list-item-factory (lambda (sym) (make-instance 'listbox-item - :md-value sym + :value sym :fm-parent *parent* :item-text (down$ (symbol-name sym))))))) @@ -190,7 +190,7 @@ :entry-values (c? (subseq (tk-eval-list "font families") 4 10))) (mk-scale :id :font-size - :md-value (c-in 14) + :value (c-in 14) :tk-label "Font Size" :from 7 :to 24 :orient 'horizontal)) @@ -201,7 +201,7 @@ :tk-justify 'left :tkfont (c? (list (selection (fm^ :font-face)) - (md-value (fm^ :font-size))))))) + (value (fm^ :font-size))))))) (defun demo-all-menubar () (mk-menubar @@ -219,7 +219,7 @@ (mk-menu-entry-command :label "Close" :command "{destroy .}") (mk-menu-entry-separator) (mk-menu-entry-command :label "Quit" - :state (c? (if t ;; (md-value (fm^ :check-me)) + :state (c? (if t ;; (value (fm^ :check-me)) 'normal 'disabled)) :command "tk_getOpenFile"))))))) ;; 'exit' in production, but under dev would take out Lisp IDE (mk-menu-entry-cascade @@ -259,6 +259,6 @@ collecting (mk-menu-entry-radiobutton :label label :value value)))))))) (mk-menu-entry-separator) (mk-menu-entry-checkbutton :id :app-font-italic :label "Italic") - (mk-menu-entry-checkbutton :id :app-font-bold :label "Bold" :md-value (c-in t)))))))))))) + (mk-menu-entry-checkbutton :id :app-font-bold :label "Bold" :value (c-in t)))))))))))) --- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/10/28 18:21:52 1.10 +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/11/04 20:53:08 1.11 @@ -216,7 +216,7 @@ ; solution to this riddle. ; (mk-entry-numeric :id :point-ct - :md-value (c-in "42") + :value (c-in "42") ; ; to help motivate "why Cells?" a little more, we deviate from ltktest 'classic" and ; start having the widgets take more interesting effect: The entry field now determines the number @@ -240,7 +240,7 @@ ; from outside the model. ; (handler-case - (let ((num (parse-integer (^md-value)))) + (let ((num (parse-integer (^value)))) (cond ((< num 2) (list (format nil "Yo, Euclid, at least two, not: ~a!!" num))) @@ -256,7 +256,7 @@ ; As you edit the field, if you key in an invalid (non-digit) character, the background ; immediately turns red. Delete it and it reverts to the default. ; - ; The interesting question is, how does the md-value slot of the Lisp instance stay + ; The interesting question is, how does the value slot of the Lisp instance stay ; current with the text being edited in the Tk entry widget? Here we have a fundamental ; difference between Ltk and Celtk. Ltk lets Tk take care of everything, including ; storing the data. eg, (text my-entry) is an accessor call that asks Tk the value of @@ -265,7 +265,7 @@ ; by having datapoints watching other datapoints, so we want data in the Lisp domain ; changing automatically as it changes on the TK side (such as when the user is actually ; typing in the entry widget). See the entry class to see how it uses the TCL "trace write" - ; mechanism to keep the Lisp md-value slot abreast of the Tk entry text configuration + ; mechanism to keep the Lisp value slot abreast of the Tk entry text configuration ; keystroke by keystroke. ; ; I added the :user-errors rule above to demonstrate the mechanism in action. Click @@ -275,28 +275,28 @@ (mk-button-ex ("Print" (format t "~&User wants to see ~A points" (fm^v :point-ct)))) ; - ; (fm^v :point-ct) -> (md-value (fm^ :point-ct)) + ; (fm^v :point-ct) -> (value (fm^ :point-ct)) ; - ; The idea being that every Cells model object has an md-value slot bearing the value + ; The idea being that every Cells model object has an value slot bearing the value ; of the thing being modeled. Here, the entry widget is modelling a place for users - ; to supply information to an application, and the md-value slot is a good place to + ; to supply information to an application, and the value slot is a good place to ; keep that information. ; - ; Thus each class uses md-value to hold something different, but in all cases it is + ; Thus each class uses value to hold something different, but in all cases it is ; the current value of whatever the instance of that class is understood to hold. ; (mk-button-ex ("Reset" (setf (fm^v :point-ct) "42"))) ; ; Driving home this point again, in Ltk one would SETF (text my-entry) and the ; SETF method would communicate with Tk to make the change to the Tk widget -text - ; configuration. In Celtk, the md-value slot of the entry gets changed (possibly + ; configuration. In Celtk, the value slot of the entry gets changed (possibly ; triggering other slots to update, which is why we do not just talk to Tk) and ; then that value gets propagated to Tk via "set <widget path> <value>". Because ; the textVariable for every entry is the entry itself, the text of the entry ; then changes. If that sounds weird, what we are actually doing is tapping into - ; the fact that Tk to a large degree takes the same approach as Cells does with md-value: + ; the fact that Tk to a large degree takes the same approach as Cells does with value: ; in Cells, we think of model instances as wrapping some model-specific - ; value, which is held in the md-value slot of the model instance. Tk simply + ; value, which is held in the value slot of the model instance. Tk simply ; allows a widget path to be a global variable. Furthermore, as the company name ; ActiveState suggests, Tk also provides automatic propagation: change the ; variable, and anyone with that as its textVariable also changes. @@ -439,7 +439,7 @@ ((num-parse :initarg :num-parse :accessor num-parse :initform (c? (eko ("numparse") (handler-case - (parse-integer (^md-value)) + (parse-integer (^value)) (parse-error (c) (princ-to-string c)))))) (num-value :initarg :num-value :accessor num-value @@ -447,7 +447,7 @@ (^num-parse) (or .cache 42))))) (:default-initargs - :md-value "42" + :value "42" :user-errors (c? (unless (numberp (^num-parse)) (^num-parse))))) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/11/03 13:37:50 1.17 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/11/04 20:53:08 1.18 @@ -192,13 +192,13 @@ -offvalue -onvalue) (:default-initargs - :md-value (c-in nil) + :value (c-in nil) :tk-variable (c? (format nil "~a.~(~a~)" (path .parent)(md-name self))) :on-command (lambda (self) - (setf (^md-value) (not (^md-value)))))) + (setf (^value) (not (^value)))))) -(defobserver .md-value ((self menu-entry-checkbutton)) - (trc nil "defobserver md-value menu-entry-checkbutton" self new-value old-value-boundp) +(defobserver .value ((self menu-entry-checkbutton)) + (trc nil "defobserver value menu-entry-checkbutton" self new-value old-value-boundp) (when (and new-value (not old-value-boundp)) (tk-format `(:variable ,self) "set ~a ~a" (^tk-variable) (if new-value 1 0)))) --- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/11/03 13:37:50 1.11 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/11/04 20:53:08 1.12 @@ -34,18 +34,18 @@ -tickinterval -to (-tk-variable nil)) (:default-initargs :id (gentemp "SCL") - :md-value (c-in nil) + :value (c-in nil) :tk-variable nil ;;(c? (^path)) :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) :on-command (lambda (self value) ;; (trc "hi scale" self value) - (setf (^md-value) (parse-integer value))))) + (setf (^value) (parse-integer value))))) (defmethod make-tk-instance :after ((self scale)) "Still necessary?" - (when (^md-value) - (tk-format `(:variable ,self) "~a set ~a" (^path) (^md-value)))) + (when (^value) + (tk-format `(:variable ,self) "~a set ~a" (^path) (^value)))) ; --- listbox -------------------------------------------------------------- @@ -70,11 +70,11 @@ (ListboxSelect (let ((selection (parse-integer (tk-eval "~a curselection" (^path))))) (setf (selection (selector self)) - (md-value (elt (^kids) selection))))))))))) + (value (elt (^kids) selection))))))))))) (defmodel listbox-item (tk-object) ((item-text :initarg :item-text :accessor item-text - :initform (c? (format nil "~a" (^md-value)))))) + :initform (c? (format nil "~a" (^value)))))) (defmethod make-tk-instance ((self listbox-item)) (trc nil "make-tk-instance listbox-item insert" self) @@ -106,22 +106,22 @@ -troughcolor -underline -xscrollcommand -validate -validatecommand (tk-values -values) -width -wrap) (:default-initargs - :md-value (c-in nil) + :value (c-in nil) :id (gentemp "SPN") :textVariable (c? (^path)) :xscrollcommand (c-in nil) :command (c? (format nil "do-on-command ~a %s" (^path))) :on-command (c? (lambda (self text) (eko ("variable mirror command fired !!!!!!!" text) - (setf (^md-value) text)))))) + (setf (^value) text)))))) -(defobserver .md-value ((self spinbox)) +(defobserver .value ((self spinbox)) (when new-value (tk-format `(:variable ,self) "set ~a ~a" (^path) (tk-send-value new-value)))) (defobserver initial-value ((self spinbox)) (when new-value (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value) - (setf (^md-value) new-value))) + (setf (^value) new-value))) --- /project/cells/cvsroot/Celtk/togl.lisp 2006/10/28 18:21:52 1.22 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/11/04 20:53:08 1.23 @@ -194,8 +194,11 @@ (def-togl-callback create () (trc "___________________ TOGL SET UP _________________________________________" 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 - #+kt-opengl (kt-opengl:kt-opengl-reset) + ; + ; just comment out these two lines if not using Cello + ; + (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready + (kt-opengl:kt-opengl-reset) (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred (setf (togl-ptr-set self) togl-ptr) ;; this gets deferred, which is OK (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))

1 0

[cells-cvs] CVS Celtk/gears
by ktilton 04 Nov '06

04 Nov '06

Update of /project/cells/cvsroot/Celtk/gears In directory clnet:/tmp/cvs-serv31024/gears Modified Files: gears.lisp Log Message: New "lite" versions of Celtk without all the Tk widgets, for PureCello --- /project/cells/cvsroot/Celtk/gears/gears.lisp 2006/06/07 22:13:41 1.2 +++ /project/cells/cvsroot/Celtk/gears/gears.lisp 2006/11/04 20:53:08 1.3 @@ -37,12 +37,12 @@ (mk-row () (mk-label :text "Spin delay (ms):") (mk-entry :id :vtime - :md-value (c-in "100")) + :value (c-in "100")) (mk-button-ex (" Quit " (tk-eval "destroy .")))) (make-instance 'gears :fm-parent *parent* :width 400 :height 400 - :timer-interval (c? (let ((n$ (md-value (fm-other :vtime)))) + :timer-interval (c? (let ((n$ (value (fm-other :vtime)))) (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" :event-handler (c? (lambda (self xe)

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 04 Nov '06

04 Nov '06

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv30831/utils-kt Modified Files: flow-control.lisp Log Message: md-value -> value --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/10/02 02:38:32 1.7 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/11/04 20:52:02 1.8 @@ -31,7 +31,7 @@ (defun min-if (v1 v2) (if v1 (if v2 (min v1 v2) v1) v2)) -(export! list-flatten! tree-flatten) +(export! list-flatten! tree-flatten list-insertf subseq-contiguous-p) (defun list-flatten! (&rest list) (if (consp list) @@ -67,6 +67,22 @@ (declare (dynamic-extent ,fn-name)) ,@body)) +(defmacro list-insertf (place item &key after) + (let ((list (gensym)) + (afterv (gensym)) + (afters (gensym))) + `(let* ((,list ,place) + (,afterv ,after) + (,afters (when ,afterv (member ,after ,list)))) + (assert (or (null ,afterv) ,afters) () "list-insertf after ~a not in list ~a" ,afterv ,list) + (setf ,place + (if ,afterv + (append (ldiff ,list ,afters) + (list ,afterv) + (list ,item) + (cdr ,afters)) + (append ,list (list ,item))))))) + (defun intern$ (&rest strings) (intern (apply #'concatenate 'string strings)))

1 0

[cells-cvs] CVS cells/cells-test
by ktilton 04 Nov '06

04 Nov '06

Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv30831/cells-test Modified Files: test-family.lisp test.lisp Log Message: md-value -> value --- /project/cells/cvsroot/cells/cells-test/test-family.lisp 2006/03/16 05:22:08 1.3 +++ /project/cells/cvsroot/cells/cells-test/test-family.lisp 2006/11/04 20:52:01 1.4 @@ -129,26 +129,26 @@ (eko ("kidnos")(when (numberp mdv) (loop for kn from 1 to (floor mdv) collecting kn)))) - :md-value (c-in 5) - :kv-key #'md-value + :value (c-in 5) + :kv-key #'value :kid-factory (lambda (f kv) (incf kf-calls) (trc "making kid" kv) (make-instance 'bottle :fm-parent f - :md-value kv + :value kv :label (c? (format nil "bottle ~d out of ~d on the wall" - (^md-value) + (^value) (length (kids f))))))))) (ct-assert (eql 5 kf-calls)) (setq kf-calls 0) - (decf (md-value wall)) + (decf (value wall)) (ct-assert (eql 4 (length (kids wall)))) (ct-assert (zerop kf-calls)) (setq kf-calls 0) - (incf (md-value wall)) + (incf (value wall)) (ct-assert (eql 5 (length (kids wall)))) (ct-assert (eql 1 kf-calls)) --- /project/cells/cvsroot/cells/cells-test/test.lisp 2006/06/23 01:04:56 1.8 +++ /project/cells/cvsroot/cells/cells-test/test.lisp 2006/11/04 20:52:01 1.9 @@ -99,19 +99,19 @@ ;; test huge number of useds by one rule (defmd m-index (family) - :md-value (c? (bwhen (ks (^kids)) - ;(trc "chya" (mapcar 'md-value ks)) - (apply '+ (mapcar 'md-value ks))))) + :value (c? (bwhen (ks (^kids)) + ;(trc "chya" (mapcar 'value ks)) + (apply '+ (mapcar 'value ks))))) (def-cell-test many-useds (let ((i (make-instance 'm-index))) (loop for n below 100 do (push (make-instance 'model :fm-parent i - :md-value (c-in n)) + :value (c-in n)) (kids i))) - (trc "index total" (md-value i)) - (ct-assert (= 4950 (md-value i))))) + (trc "index total" (value i)) + (ct-assert (= 4950 (value i))))) #+test (many-useds)

1 0

[cells-cvs] CVS cells
by ktilton 04 Nov '06

04 Nov '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv30831 Modified Files: cells.lpr defpackage.lisp family-values.lisp family.lisp fm-utilities.lisp integrity.lisp test.lisp Log Message: md-value -> value --- /project/cells/cvsroot/cells/cells.lpr 2006/10/17 21:28:39 1.22 +++ /project/cells/cvsroot/cells/cells.lpr 2006/11/04 20:52:01 1.23 @@ -23,11 +23,7 @@ (make-instance 'module :name "md-utilities.lisp") (make-instance 'module :name "family.lisp") (make-instance 'module :name "fm-utilities.lisp") - (make-instance 'module :name "family-values.lisp") - (make-instance 'module :name - "doc\\01-Cell-basics.lisp") - (make-instance 'module :name - "doc\\motor-control.lisp")) + (make-instance 'module :name "family-values.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\\utils-kt")) :libraries nil --- /project/cells/cvsroot/cells/defpackage.lisp 2006/10/17 21:28:39 1.8 +++ /project/cells/cvsroot/cells/defpackage.lisp 2006/11/04 20:52:01 1.9 @@ -52,7 +52,7 @@ #:defmodel #:defmd #:defobserver #:slot-value-observe #:def-c-unchanged-test #:new-value #:old-value #:old-value-boundp #:c... #:md-awaken - #:mkpart #:make-kid #:the-kids #:nsib #:md-value #:^md-value #:.md-value #:kids #:^kids #:.kids + #:mkpart #:make-kid #:the-kids #:nsib #:value #:^value #:.value #:kids #:^kids #:.kids #:cells-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 --- /project/cells/cvsroot/cells/family-values.lisp 2006/05/20 06:32:19 1.4 +++ /project/cells/cvsroot/cells/family-values.lisp 2006/11/04 20:52:01 1.5 @@ -30,7 +30,7 @@ :reader kv-collector) (kid-values :initform (c? (when (kv-collector self) - (funcall (kv-collector self) (^md-value)))) + (funcall (kv-collector self) (^value)))) :accessor kid-values :initarg :kid-values) --- /project/cells/cvsroot/cells/family.lisp 2006/11/03 13:37:10 1.15 +++ /project/cells/cvsroot/cells/family.lisp 2006/11/04 20:52:01 1.16 @@ -19,12 +19,12 @@ (in-package :cells) (eval-when (:compile-toplevel :execute :load-toplevel) - (export '(model md-value family kids kid1 ^k1 kid2 ^k2 last-kid ^k-last perishable))) + (export '(model value family kids kid1 ^k1 kid2 ^k2 last-kid ^k-last perishable))) (defmodel model () ((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name) (.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent) - (.md-value :initform nil :accessor md-value :initarg :md-value))) + (.value :initform nil :accessor value :initarg :value))) (defmethod fm-parent (other) @@ -90,6 +90,11 @@ (if (typep ,self ',type) ,self (upper ,self ,type))))) (defun kid1 (self) (car (kids self))) + +(export! first-born-p) +(defun first-born-p (self) + (eq self (kid1 .parent))) + (defun kid2 (self) (cadr (kids self))) (defmacro ^k1 () `(kid1 self)) (defmacro ^k2 () `(kid2 self)) --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/11/03 13:37:10 1.13 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/11/04 20:52:01 1.14 @@ -403,7 +403,7 @@ (export! fmv) (defmacro fmv (name) - `(md-value (fm-other ,name))) + `(value (fm-other ,name))) (defmacro fm-otherx (md-name &key (starting 'self) skip-tree) (if (eql starting 'self) @@ -448,7 +448,7 @@ :global-search t))) (defmacro fm^v (id) - `(md-value (fm^ ,id))) + `(value (fm^ ,id))) (defmacro fm? (md-name &optional (starting 'self) (global-search t)) `(fm-find-one ,starting ,(if (consp md-name) @@ -466,7 +466,7 @@ :global-search nil))) (defmacro fm!v (id) - `(md-value (fm! ,id))) + `(value (fm! ,id))) (defmacro fm-other?! (md-name &optional (starting 'self)) `(fm-find-one ,starting ,(if (consp md-name) --- /project/cells/cvsroot/cells/integrity.lisp 2006/10/17 21:28:39 1.14 +++ /project/cells/cvsroot/cells/integrity.lisp 2006/11/04 20:52:01 1.15 @@ -30,12 +30,18 @@ "Invalid second value to with-integrity: ~a" opcode)) `(call-with-integrity ,opcode ,defer-info (lambda () ,@body))) -(export! with-c-change) +(export! with-c-change with-c-changes) (defmacro with-c-change (id &body body) `(with-integrity (:change ,id) ,@body)) +(defmacro with-c-changes (id &rest change-forms) + `(with-c-change ,id + ,(car change-forms) + ,(when (cdr change-forms) + `(with-c-changes ,id ,@(cdr change-forms))))) + (defun integrity-managed-p () *within-integrity*) @@ -68,6 +74,8 @@ (or (ufb-queue opcode) (cdr (car (push (cons opcode (make-fifo-queue)) *unfinished-business*))))) +(defparameter *no-tell* nil) + (defun ufb-add (opcode continuation) (assert (find opcode *ufb-opcodes*)) (when (and *no-tell* (eq opcode :tell-dependents)) @@ -83,7 +91,7 @@ while task do (trc nil "unfin task is" opcode task) (funcall task))) -(defparameter *no-tell* nil) + (defun finish-business () (when *stop* (return-from finish-business)) (tagbody --- /project/cells/cvsroot/cells/test.lisp 2006/06/23 01:04:56 1.8 +++ /project/cells/cvsroot/cells/test.lisp 2006/11/04 20:52:01 1.9 @@ -97,16 +97,16 @@ (defmodel m-index (family) () (:default-initargs - :md-value (c? (bwhen (ks (^kids)) - (apply '+ (mapcar 'md-value ks)))))) + :value (c? (bwhen (ks (^kids)) + (apply '+ (mapcar 'value ks)))))) (def-cell-test many-useds (let ((i (make-instance 'm-index))) (loop for n below 100 do (push (make-instance 'model - :md-value (c-in n)) + :value (c-in n)) (kids i))) - (trc "index total" (md-value i)))) + (trc "index total" (value i)))) (defmodel m-null () ((aa :initform nil :cell nil :initarg :aa :accessor aa)))

1 0

[cells-cvs] CVS cells/doc
by ktilton 04 Nov '06

04 Nov '06

Update of /project/cells/cvsroot/cells/doc In directory clnet:/tmp/cvs-serv30831/doc Modified Files: 01-Cell-basics.lisp Log Message: md-value -> value --- /project/cells/cvsroot/cells/doc/01-Cell-basics.lisp 2006/05/20 06:32:19 1.4 +++ /project/cells/cvsroot/cells/doc/01-Cell-basics.lisp 2006/11/04 20:52:01 1.5 @@ -309,10 +309,10 @@ parent slot, which gets used along with a family's kids slot to form simple trees navigable up and down. -model-objects also have slots for md-name and md-value (don't +model-objects also have slots for md-name and value (don't worry camelcase-haters, that is a declining feature of my code). md-name lets the family trees we build be treated as namespaces. -md-value just turns out to be very handy for a lot of things. for +value just turns out to be very handy for a lot of things. for example, a check-box instance needs some place to indicate its boolean state. @@ -323,7 +323,7 @@ rules we write, and the side-effects we specify via observer functions. the silly example below just shows the summer (that which sums) getting -a new md-value as the kids change, along with some observer output. in real-world +a new value as the kids change, along with some observer output. in real-world applications, where kids represent gui elements often dependent on each other, vastly more can transpire before a simple push into a kids slot has run its course. @@ -335,15 +335,15 @@ () (:default-initargs :kids (c-in nil) ;; or we cannot add any addend kids later - :md-value (c? (reduce #'+ (kids self) + :value (c? (reduce #'+ (kids self) :initial-value 0 - :key #'md-value)))) + :key #'value)))) -(defobserver md-value ((self summer)) +(defobserver value ((self summer)) (trc "the sum of the values of the kids is" new-value)) (defobserver .kids ((self summer)) - (trc "the values of the kids are" (mapcar #'md-value new-value))) + (trc "the values of the kids are" (mapcar #'value new-value))) ;----------------------------------------------------------- ; now just evaluate each of the following forms one by one, @@ -364,7 +364,7 @@ (push (make-instance 'model :fm-parent *f1* - :md-value 1) (kids *f1*)) + :value 1) (kids *f1*)) #| observe: 0> the values of the kids are (1) @@ -376,7 +376,7 @@ (push (make-instance 'model :fm-parent *f1* - :md-value 2) (kids *f1*)) + :value 2) (kids *f1*)) #| observe: 0> the values of the kids are (2 1)

1 0