From ktilton at common-lisp.net Mon Jan 29 06:44:03 2007 From: ktilton at common-lisp.net (ktilton) Date: Mon, 29 Jan 2007 01:44:03 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20070129064403.EB4702201B@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv3487 Modified Files: cell-types.lisp cells.lisp cells.lpr constructors.lisp family.lisp fm-utilities.lisp integrity.lisp link.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp propagate.lisp slot-utilities.lisp trc-eko.lisp variables.lisp Log Message: Some interesting changes --- /project/cells/cvsroot/cells/cell-types.lisp 2006/12/12 15:58:42 1.24 +++ /project/cells/cvsroot/cells/cell-types.lisp 2007/01/29 06:43:48 1.25 @@ -87,9 +87,7 @@ (defun caller-drop (used caller) (fifo-delete (c-caller-store used) caller)) -;;;(defmethod trcp ((c cell)) -;;; (and (typep (c-model c) 'index) -;;; (find (c-slot-name c) '(mathx::line-breaks mathx::phrases)))) + ; --- ephemerality -------------------------------------------------- ; --- /project/cells/cvsroot/cells/cells.lisp 2006/12/12 15:58:42 1.19 +++ /project/cells/cvsroot/cells/cells.lisp 2007/01/29 06:43:52 1.20 @@ -17,7 +17,7 @@ |# (eval-when (compile load) - (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3)))) + (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3)))) (in-package :cells) @@ -79,7 +79,7 @@ `(call-without-c-dependency (lambda () , at body))) (defun call-without-c-dependency (fn) - (let (*call-stack*); *no-tell*) + (let (*call-stack*) (funcall fn))) (export! .cause) --- /project/cells/cvsroot/cells/cells.lpr 2006/12/13 18:05:08 1.26 +++ /project/cells/cvsroot/cells/cells.lpr 2007/01/29 06:43:59 1.27 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Dec 9, 2006 20:44)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cells/cvsroot/cells/constructors.lisp 2006/12/13 18:05:08 1.15 +++ /project/cells/cvsroot/cells/constructors.lisp 2007/01/29 06:43:59 1.16 @@ -26,10 +26,13 @@ (defmacro c-lambda (&body body) `(c-lambda-var (slot-c) , at body)) +(export! .cache-bound-p) + (defmacro c-lambda-var ((c) &body body) `(lambda (,c &aux (self (c-model ,c)) - (.cache (c-value ,c))) - (declare (ignorable .cache self)) + (.cache (c-value ,c)) + (.cache-bound-p (cache-bound-p ,c))) + (declare (ignorable .cache .cache-bound-p self)) , at body)) (defmacro with-c-cache ((fn) &body body) --- /project/cells/cvsroot/cells/family.lisp 2006/12/13 18:05:08 1.18 +++ /project/cells/cvsroot/cells/family.lisp 2007/01/29 06:43:59 1.19 @@ -39,7 +39,8 @@ (defmethod print-object ((self model) s) #+shhh (format s "~a" (type-of self)) - (format s "~a" (or (md-name self) (type-of self)))) + (format s "~a~a" (if (mdead self) "DEAD!" "") + (or (md-name self) (type-of self)))) (define-symbol-macro .parent (fm-parent self)) --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/11/04 20:52:01 1.14 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2007/01/29 06:43:59 1.15 @@ -44,7 +44,7 @@ (defmacro upper (self &optional (type t)) `(container-typed ,self ',type)) -(export! u^) +(export! u^ fm-descendant-if) (defmacro u^ (type) `(upper self ,type)) @@ -93,6 +93,13 @@ self) (fm-ascendant-if .parent if-function)))) +(defun fm-descendant-if (self test) + (when (and self test) + (or (when (funcall test self) + self) + (loop for k in (^kids) + thereis (fm-descendant-if k test))))) + (defun fm-ascendant-common (d1 d2) (fm-ascendant-some d1 (lambda (node) (when (fm-includes node d2) @@ -440,11 +447,11 @@ :must-find t :global-search global-search)) -(defmacro fm^ (md-name &key (skip-tree 'self)) +(defmacro fm^ (md-name &key (skip-tree 'self) (must-find t)) `(without-c-dependency (fm-find-one (fm-parent self) ,md-name :skip-tree ,skip-tree - :must-find t + :must-find ,must-find :global-search t))) (defmacro fm^v (id) @@ -494,7 +501,7 @@ :must-find nil :global-search ,global-search))) ;--------------------------------------------------------------- - +(export! fm-top) (defun fm-top (fm &optional (test #'true-that) &aux (fm-parent (fm-parent fm))) (cond ((null fm-parent) fm) ((not (funcall test fm-parent)) fm) --- /project/cells/cvsroot/cells/integrity.lisp 2006/11/13 05:28:08 1.16 +++ /project/cells/cvsroot/cells/integrity.lisp 2007/01/29 06:44:00 1.17 @@ -84,7 +84,7 @@ (defun just-do-it (op-or-q &aux (q (if (keywordp op-or-q) (ufb-queue op-or-q) op-or-q))) - (trc nil "just do it doing" op-or-q) + (trc nil "----------------------------just do it doing---------------------" op-or-q) (loop for (defer-info . task) = (fifo-pop q) while task do (trc nil "unfin task is" opcode task) @@ -165,7 +165,7 @@ (bwhen (task-info (fifo-pop (ufb-queue :change))) (trc nil "!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change))) (destructuring-bind (defer-info . task-fn) task-info - (trc nil "finbiz: deferred state change" defer-info) + (trc nil "finbiz: deferred state change" defer-info) (data-pulse-next (list :finbiz defer-info)) (funcall task-fn :change defer-info) ; @@ -178,3 +178,4 @@ ; (go tell-dependents))))) + --- /project/cells/cvsroot/cells/link.lisp 2006/12/12 15:58:42 1.22 +++ /project/cells/cvsroot/cells/link.lisp 2007/01/29 06:44:01 1.23 @@ -18,21 +18,11 @@ (in-package :cells) -#+(or) -(eval-when (compile load) - (proclaim '(optimize (speed 3) (safety 0) (space 0) (debug 0)))) - - (defun record-caller (used &aux (caller (car *call-stack*))) (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell (trc nil "caller not being recorded because used optimized away" caller (c-value used) :used used) (return-from record-caller nil)) (trc nil "record-caller entry: used=" used :caller caller) -;;; (when (trcp caller) -;;; -;;; ;;(when (eq (c-slot-name caller) 'mathx::phrases) -;;; (when (eq (c-slot-name used) 'mathx::opnds) -;;; (break "bingo"))) (multiple-value-bind (used-pos useds-len) (loop with u-pos @@ -121,7 +111,7 @@ ;---------------------------------------------------------- (defun c-unlink-caller (used caller) - (trc caller "(1) caller unlinking from (2) used" caller used) + (trc nil "(1) caller unlinking from (2) used" caller used) (caller-drop used caller) (c-unlink-used caller used)) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/12/12 15:58:42 1.33 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2007/01/29 06:44:01 1.34 @@ -21,6 +21,9 @@ (defparameter *ide-app-hard-to-kill* t) (defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name))) + (when (mdead self) + (trc "md-slot-value passed dead self, returning NIL" self) + (return-from md-slot-value nil)) (tagbody retry (when *stop* @@ -55,6 +58,12 @@ (when (eq :eternal-rest (md-state 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)))) + (defun ensure-value-is-current (c debug-id ensurer) ; ; ensurer can be used cell propagating to callers, or an existing caller who wants to make sure @@ -69,7 +78,7 @@ (cond ((c-currentp c) - (trc c "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete + (trc nil "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete ;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete ;; ((and (c-inputp c) @@ -106,7 +115,12 @@ (when (c-unboundp c) (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c))) - (c-value c)) + (bwhen (v (c-value c)) + (if (mdead v) + (progn + (trc "ensure-value not returning dead model object value" v) + nil) + v))) (defun calculate-and-set (c) (flet ((body () @@ -260,11 +274,17 @@ (unless (eq propagation-code :no-propagate) (trc nil "md-slot-value-assume flagging as changed: prior state, value:" prior-state prior-value ) (setf (c-pulse-last-changed c) *data-pulse-id*) - (c-propagate c prior-value (or (eq prior-state :valid) - (eq prior-state :uncurrent)))) ;; until 06-02-13 was (not (eq prior-state :unbound)) + (c-propagate c prior-value (cache-state-bound-p prior-state))) ;; until 06-02-13 was (not (eq prior-state :unbound)) absorbed-value))) +(defun cache-bound-p (c) + (cache-state-bound-p (c-value-state c))) + +(defun cache-state-bound-p (value-state) + (or (eq value-state :valid) + (eq value-state :uncurrent))) + ;---------- optimizing away cells whose dependents all turn out to be constant ---------------- ; --- /project/cells/cvsroot/cells/md-utilities.lisp 2006/11/03 13:37:10 1.11 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2007/01/29 06:44:01 1.12 @@ -27,29 +27,39 @@ (defmethod md-release (other) (declare (ignorable other))) -(export! md-dead) -(defun md-dead (SELF) - (eq :eternal-rest (md-state SELF))) +(export! mdead) ;___________________ birth / death__________________________________ -(defmethod not-to-be :around (self) - (trc nil "not-to-be nailing") - (c-assert (not (eq (md-state self) :eternal-rest))) +(defgeneric mdead (self) - (call-next-method) + (:method ((self model-object)) + (eq :eternal-rest (md-state SELF))) - (setf (fm-parent self) nil - (md-state self) :eternal-rest) + (:method (self) + (declare (ignore self)) + nil)) - (md-map-cells self nil - (lambda (c) - (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not-to-be with primary method (use :before etc) +(defgeneric not-to-be (self) - (trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self)) + (:method ((self model-object)) + (md-quiesce self)) -(defmethod not-to-be ((self model-object)) - (trc nil "not to be!!!" self) - (md-quiesce self)) + (:method :around ((self model-object)) + (declare (ignorable self)) + (trc nil #+not (typep self '(or mathx::problem mathx::prb-solvers mathx::prb-solver)) + "not-to-be nailing" self) + (c-assert (not (eq (md-state self) :eternal-rest))) + + (call-next-method) + + (setf (fm-parent self) nil + (md-state self) :eternal-rest) + + (md-map-cells self nil + (lambda (c) + (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not-to-be with primary method (use :before etc) + + (trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self))) (defun md-quiesce (self) (trc nil "md-quiesce nailing cells" self (type-of self)) @@ -70,8 +80,7 @@ (setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho ))) -(defmethod not-to-be (other) - other) + (defparameter *to-be-dbg* nil) --- /project/cells/cvsroot/cells/model-object.lisp 2006/11/13 05:28:08 1.14 +++ /project/cells/cvsroot/cells/model-object.lisp 2007/01/29 06:44:01 1.15 @@ -116,7 +116,7 @@ (trc nil "md-awaken entry" self (md-state self)) (c-assert (eql :nascent (md-state self))) (count-it :md-awaken) - (count-it 'mdawaken) + ;(count-it 'mdawaken (type-of self)) ; --- --- /project/cells/cvsroot/cells/propagate.lisp 2006/11/13 05:28:08 1.26 +++ /project/cells/cvsroot/cells/propagate.lisp 2007/01/29 06:44:01 1.27 @@ -46,7 +46,7 @@ (defun c-pulse-update (c key) (declare (ignorable key)) - (trc nil "c-pulse-update updating" *data-pulse-id* c key :prior-pulse (c-pulse c)) + (trc nil "!!!!!!! c-pulse-update updating !!!!!!!!!!" *data-pulse-id* c key :prior-pulse (c-pulse c)) (assert (>= *data-pulse-id* (c-pulse c)) () "Current DP ~a not GE pulse ~a of cell ~a" *data-pulse-id* (c-pulse c) c) (setf (c-pulse c) *data-pulse-id*)) @@ -59,7 +59,7 @@ ; (defun c-propagate (c prior-value prior-value-supplied) - + (count-it :c-propagate) (when prior-value (assert prior-value-supplied () "How can prior-value-supplied be nil if prior-value is not?!! ~a" c)) @@ -67,13 +67,13 @@ (*c-prop-depth* (1+ *c-prop-depth*)) (*defer-changes* t)) (trc nil "c-propagate clearing *call-stack*" c) - + ;------ debug stuff --------- ; (when *stop* (princ #\.)(princ #\!) (return-from c-propagate)) - (trc c "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)) c) + (trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers 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) @@ -97,10 +97,10 @@ (flet ((listify (x) (if (listp x) x (list x)))) (bIf (lost (set-difference (listify prior-value) (listify (c-value c)))) (progn - (trc nil "prop nailing owned" c :lost lost :leaving (c-value c)) + (trc nil "prop nailing owned!!!!!!!!!!!" c :lost lost :leaving (c-value c)) (mapcar 'not-to-be lost)) (trc nil "no owned lost!!!!!")))) - + ; propagation to callers jumps back in front of client slot-value-observe handling in cells3 ; because model adopting (once done by the kids change handler) can now be done in ; shared-initialize (since one is now forced to supply the parent to make-instance). @@ -111,10 +111,10 @@ ; (unless nil #+not (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this (c-propagate-to-callers c)) - + (slot-value-observe (c-slot-name c) (c-model c) (c-value c) prior-value prior-value-supplied) - + ; ; with propagation done, ephemerals can be reset. we also do this in c-awaken, so @@ -185,21 +185,26 @@ (and (c-lazy caller) ;; slight optimization (member (c-lazy caller) '(t :always :once-asked)))) (c-callers c)) - (let ((causation (cons c *causation*)) ;; in case deferred - ) - (TRC c "c-propagate-to-callers > queueing notifying callers" (mapcar 'c-slot-name (c-callers c))) + (let ((causation (cons c *causation*))) ;; in case deferred + (TRC nil "c-propagate-to-callers > queueing notifying callers" (c-callers c)) (with-integrity (:tell-dependents c) (assert (null *call-stack*)) (let ((*causation* causation)) - (trc c "c-propagate-to-callers > actually notifying callers of" c (mapcar 'c-slot-name (c-callers c))) - (dolist (caller (c-callers c)) - (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller)) - - (dolist (caller (c-callers c)) ;; following code may modify c-callers list... + (trc nil "c-propagate-to-callers > actually notifying callers of" c (c-callers c)) + #+c-debug (dolist (caller (c-callers c)) + (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller)) + (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list... + (trc nil "PRE-prop-CHECK " c :caller caller (c-state caller) (c-lazy caller)) + (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced + (member (c-lazy caller) '(t :always :once-asked))) + (assert (find c (cd-useds caller))() "Precheck Caller ~a of ~a does not have it as used" caller c) + )) + (dolist (caller (progn #+not copy-list (c-callers c))) ;; following code may modify c-callers list... + (trc nil "propagating to caller iterates" c :caller caller (c-state caller) (c-lazy caller)) (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced (member (c-lazy caller) '(t :always :once-asked))) - (assert (find c (cd-useds caller))) - (trc caller "propagating to caller is caller:" caller) + (assert (find c (cd-useds caller))() "Caller ~a of ~a does not have it as used" caller c) + (trc nil "propagating to caller is used" c :caller caller) (ensure-value-is-current caller :prop-from c)))))))) --- /project/cells/cvsroot/cells/slot-utilities.lisp 2006/11/13 05:28:08 1.4 +++ /project/cells/cvsroot/cells/slot-utilities.lisp 2007/01/29 06:44:01 1.5 @@ -36,7 +36,7 @@ ;; cv-test handles errors, so don't set *stop* (c-stop) (c-break "unadopted ~a for self ~a spec ~a" c self slot-name) (error 'c-unadopted :cell c)) - (typecase c + #+whocares (typecase c (c-dependent ;(trc "setting c-dependent" c newvalue) (format t "c-setting-debug > ruled ~a in ~a may not be setf'ed" --- /project/cells/cvsroot/cells/trc-eko.lisp 2006/10/28 18:20:48 1.5 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2007/01/29 06:44:01 1.6 @@ -52,9 +52,9 @@ (if (eql tgt-form 'nil) '(progn) `(without-c-dependency - (call-trc t ,(format nil "TX> ~(~a~)" tgt-form) + (call-trc t ,(format nil "TX> ~(~s~)" tgt-form) ,@(loop for obj in os - nconcing (list (format nil "~a:" obj) obj)))))) + nconcing (list (intern (format nil "~a" obj) :keyword) obj)))))) (defparameter *last-trc* (get-internal-real-time)) --- /project/cells/cvsroot/cells/variables.lisp 2006/12/13 18:05:08 1.1 +++ /project/cells/cvsroot/cells/variables.lisp 2007/01/29 06:44:01 1.2 @@ -60,6 +60,7 @@ #+test (def-c-variable *kenny* (c-in nil)) + #+test (defmd kenny-watcher () (twice (c? (bwhen (k *kenny*) From ktilton at common-lisp.net Mon Jan 29 06:44:04 2007 From: ktilton at common-lisp.net (ktilton) Date: Mon, 29 Jan 2007 01:44:04 -0500 (EST) Subject: [cells-cvs] CVS cells/gui-geometry Message-ID: <20070129064404.34E602201C@common-lisp.net> Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv3487/gui-geometry Modified Files: gui-geometry.lpr Log Message: Some interesting changes --- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/11/13 05:28:08 1.7 +++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2007/01/29 06:44:03 1.8 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Mon Jan 29 06:44:04 2007 From: ktilton at common-lisp.net (ktilton) Date: Mon, 29 Jan 2007 01:44:04 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20070129064404.84A4724007@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv3487/utils-kt Modified Files: debug.lisp detritus.lisp flow-control.lisp utils-kt.lpr Log Message: Some interesting changes --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/10/02 02:38:32 1.13 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2007/01/29 06:44:04 1.14 @@ -30,6 +30,7 @@ (setf *count* nil *stop* nil *dbg* nil) + (print "----------UTILSRESET----------------------------------")) @@ -93,9 +94,10 @@ (defmacro timex ((onp &rest trcargs) &body body) `(if ,onp - (prog1 + (prog2 + (format t "~&Starting timing run of ~{ ~a~}" (list , at trcargs)) (time (progn , at body)) - (format t "timing was of ~{ ~a~}" , at trcargs)) + (format t "~&Above timing was of ~{ ~a~}" (list , at trcargs))) (progn , at body))) #+save --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/12/12 15:58:43 1.12 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2007/01/29 06:44:04 1.13 @@ -170,16 +170,15 @@ (typecase tree (null) (atom (funcall test sought tree)) - (cons (loop for subtree in tree - when (tree-includes sought subtree :test test) - do (return-from tree-includes t))))) + (cons (or (tree-includes sought (car tree) :test test) + (tree-includes sought (cdr tree) :test test))))) (defun tree-traverse (tree fn) (typecase tree (null) (atom (funcall fn tree)) - (cons (loop for subtree in tree - do (tree-traverse subtree fn)))) + (cons (tree-traverse (car tree) fn) + (tree-traverse (cdr tree) fn))) (values)) (defun tree-intersect (t1 t2 &key (test 'eql)) --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/12/12 15:58:43 1.9 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2007/01/29 06:44:04 1.10 @@ -31,7 +31,7 @@ (defun min-if (v1 v2) (if v1 (if v2 (min v1 v2) v1) v2)) -(export! list-flatten! tree-flatten list-insertf subseq-contiguous-p) +(export! list-flatten! tree-flatten list-insertf subseq-contiguous-p pair-off) (defun list-flatten! (&rest list) (if (consp list) @@ -59,6 +59,17 @@ (defun tree-flatten (tree) (list-flatten! (copy-tree tree))) +(defun pair-off (list &optional (test 'eql)) + (loop with pairs and copy = (copy-list list) + while (cdr copy) + do (let ((pair (find (car copy) (cdr copy) :test test))) + (if pair + (progn + (push-end (cons (car copy) pair) pairs) + (setf copy (delete pair (cdr copy) :count 1))) + (setf copy (cdr copy)))) + finally (return pairs))) + (defun packed-flat! (&rest u-nameit) (delete nil (list-flatten! u-nameit))) @@ -173,6 +184,7 @@ (export! without-repeating) + (let ((generators (make-hash-table :test 'equalp))) (defun without-repeating (key all &optional (decent-interval (floor (length all) 2))) (funcall (or (gethash key generators) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/12/12 15:58:43 1.21 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2007/01/29 06:44:04 1.22 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- (in-package :cg-user) From ktilton at common-lisp.net Mon Jan 29 22:58:42 2007 From: ktilton at common-lisp.net (ktilton) Date: Mon, 29 Jan 2007 17:58:42 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20070129225842.1C1BB19001@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv31381 Modified Files: Celtk.lisp lotsa-widgets.lisp movie.lisp multichoice.lisp tk-interp.lisp tk-object.lisp Log Message: a little more on the movie widget --- /project/cells/cvsroot/Celtk/Celtk.lisp 2007/01/29 06:48:41 1.39 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2007/01/29 22:58:41 1.40 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.39 2007/01/29 06:48:41 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.40 2007/01/29 22:58:41 ktilton Exp $ (pushnew :tile *features*) @@ -114,7 +114,7 @@ ; --- debug stuff --------------------------------- ; - (let ((yes '("movie" "play")) + (let ((yes '("play-me")) (no '("font"))) (declare (ignorable yes no)) (when (and (or ;; (null yes) --- /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2007/01/29 06:48:41 1.9 +++ /project/cells/cvsroot/Celtk/lotsa-widgets.lisp 2007/01/29 22:58:41 1.10 @@ -74,35 +74,27 @@ (style-by-widgets) (mk-row (:layout-anchor 'sw) - (mk-entry - :id :enter-me - :event-handler (lambda (self xe) - (case (tk-event-type (xsv type xe)) - (:virtualevent - (case (read-from-string (string-upcase (xsv name xe))) - (trace (let ((new-value (ctk::tcl-get-var ctk::*tki* (^path) - (ctk::var-flags :TCL-NAMESPACE-ONLY)))) - (unless (string= new-value (^value)) ;; I guess it would loop - (setf (^value) new-value)) - (cond - ((find new-value '("bush" "war" "anger" "hate") :test 'string-equal) - (setf (tk-file (fm^ :play-me)) - "c:/0dev/celtk/demo.mov")) - ((find new-value '("sex" "drugs" "rock-n-roll" "peace") :test 'string-equal) - (setf (tk-file (fm^ :play-me)) - "c:/0dev/celtk/good-thing2.mov")))))))))) + (mk-entry :id :enter-me) (mk-label :text (c? (conc$ "echo " (fm^v :enter-me)))))) (mk-stack () (duelling-scrolled-lists) (mk-row () - (mk-button-ex ("Serious Demo" (setf (tk-file (fm^ :play-me)) - "c:/0dev/celtk/demo.mov"))) - (mk-button-ex ("Celtk?" (setf (tk-file (fm^ :play-me)) - "c:/0dev/celtk/good-thing2.mov")))) + (mk-button-ex ("Serious Demo" (plug-n-play-movie (fm^ :play-me) + "c:/0dev/celtk/demo.mov"))) + (mk-button-ex ("Celtk?" (plug-n-play-movie (fm^ :play-me) + "c:/0dev/celtk/good-thing2.mov")))) + (mk-movie :id :play-me - :tk-file (c-in "c:/0dev/celtk/good-thing2.mov"))))))))))) + :loopstate (c-in 0) :palindromeloopstate (c-in 0) + :tk-file (c? (let ((entry (fm^v :enter-me))) + (cond + ((find entry '("bush" "war" "anger" "hate") :test 'string-equal) + "c:/0dev/celtk/demo.mov") + ((find entry '("sex" "drugs" "rock-n-roll" "peace") :test 'string-equal) + "c:/0dev/celtk/good-thing2.mov") + (t "c:/0dev/celtk/good-thing2.mov" #+not .cache)))))))))))))) (defun style-by-edit-menu () (mk-row ("Style by Edit Menu") --- /project/cells/cvsroot/Celtk/movie.lisp 2007/01/29 06:48:42 1.1 +++ /project/cells/cvsroot/Celtk/movie.lisp 2007/01/29 22:58:41 1.2 @@ -18,14 +18,34 @@ (in-package :celtk) -(export! mk-movie url tk-file) +(export! mk-movie url tk-file plug-n-play-movie) + (deftk movie (widget) - () - (:tk-spec movie -url (tk-file -file)) + ((loop :initarg :loop :accessor loop)) ;; fnyi + (:tk-spec movie -url (tk-file -file) + -controller -custombutton -highlightbackground -highlightcolor + -highlightthickness -height -loadcommand -loadintoram -loopstate + -mccommand -mcedit -palindromeloopstate -preferredrate -progressproc + -qtprogress -qtvrqualitymotion -qtvrqualitystatic -resizable + -swing -swingspeed -volume -width) (:default-initargs :tile? nil)) (defobserver tk-file :around ((self movie)) (call-next-method) (when (and new-value old-value) - (tk-format `(:fini ,self) "~a play" (^path)))) + (plug-n-play-movie self new-value nil))) + +(defun plug-n-play-movie (m file &optional (install? t)) + ; + ; silly harcodes follow.... + ; + (when install? (setf (tk-file m) file)) + ; + ; this off-on sequence apparently necessary each time a file is loaded or sth. + ; + (with-cc :loopstate + (setf (palindromeloopstate m) 0) + (with-cc :loopstate + (setf (palindromeloopstate m) 1) + (tk-format `(:fini ,m) "~a play" (path m))))) \ No newline at end of file --- /project/cells/cvsroot/Celtk/multichoice.lisp 2007/01/29 06:48:41 1.13 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2007/01/29 22:58:41 1.14 @@ -114,8 +114,7 @@ :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 (^value) text)))))) + (setf (^value) text))))) (defobserver .value ((self spinbox)) (when new-value @@ -123,7 +122,6 @@ (defobserver initial-value ((self spinbox)) (when new-value - (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value) (setf (^value) new-value))) --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2007/01/29 06:48:41 1.17 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2007/01/29 22:58:41 1.18 @@ -124,8 +124,6 @@ (flags :int)) (defun tcl-eval-ex (i s) - (when (search "package" s) - (print s)) (tcl_evalex i s -1 0)) (defcfun ("Tcl_GetVar" tcl-get-var) :string (interp :pointer)(varName :string)(flags :int)) --- /project/cells/cvsroot/Celtk/tk-object.lisp 2007/01/29 06:48:41 1.11 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2007/01/29 22:58:41 1.12 @@ -84,7 +84,7 @@ (defgeneric tk-class-options (self) (:method-combination append) (:method :around (self) - (or ;;(get (type-of self) 'tk-class-options) + (or (get (type-of self) 'tk-class-options) (setf (get (type-of self) 'tk-class-options) (loop with all = (remove-duplicates (call-next-method) :key 'second) for old in (when (tile? self) From ktilton at common-lisp.net Mon Jan 29 23:06:35 2007 From: ktilton at common-lisp.net (ktilton) Date: Mon, 29 Jan 2007 18:06:35 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20070129230635.929652B032@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv1911 Modified Files: Celtk.asd movie.lisp Log Message: --- /project/cells/cvsroot/Celtk/Celtk.asd 2006/07/06 22:10:39 1.11 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2007/01/29 23:06:35 1.12 @@ -12,7 +12,7 @@ :licence "Lisp LGPL" :description "Tcl/Tk with Cells Inside(tm)" :long-description "A Cells-driven portable GUI, ultimately implmented by Tcl/Tk" - :depends-on (:cells :cffi :gui-geometry :cl-ftgl) + :depends-on (:cells :cffi :gui-geometry) :serial t :components ((:file "Celtk") (:file "tk-structs") --- /project/cells/cvsroot/Celtk/movie.lisp 2007/01/29 22:58:41 1.2 +++ /project/cells/cvsroot/Celtk/movie.lisp 2007/01/29 23:06:35 1.3 @@ -21,7 +21,7 @@ (export! mk-movie url tk-file plug-n-play-movie) (deftk movie (widget) - ((loop :initarg :loop :accessor loop)) ;; fnyi + () (:tk-spec movie -url (tk-file -file) -controller -custombutton -highlightbackground -highlightcolor -highlightthickness -height -loadcommand -loadintoram -loopstate From ktilton at common-lisp.net Mon Jan 29 23:14:28 2007 From: ktilton at common-lisp.net (ktilton) Date: Mon, 29 Jan 2007 18:14:28 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20070129231428.195DD2E1B7@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv2771 Added Files: cffi.lpr Log Message: --- /project/cells/cvsroot/Celtk/cffi.lpr 2007/01/29 23:14:28 NONE +++ /project/cells/cvsroot/Celtk/cffi.lpr 2007/01/29 23:14:28 1.1 ;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :COMMON-GRAPHICS-USER) (define-project :name :cffi :modules (list (make-instance 'module :name "src\\utils.lisp") (make-instance 'module :name "src\\features.lisp") (make-instance 'module :name "src\\cffi-allegro.lisp") (make-instance 'module :name "src\\package.lisp") (make-instance 'module :name "src\\libraries.lisp") (make-instance 'module :name "src\\early-types.lisp") (make-instance 'module :name "src\\types.lisp") (make-instance 'module :name "src\\enum.lisp") (make-instance 'module :name "src\\strings.lisp") (make-instance 'module :name "src\\functions.lisp") (make-instance 'module :name "src\\foreign-vars.lisp") (make-instance 'module :name "uffi-compat\\uffi-compat.lisp")) :projects nil :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :common-graphics-user :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.icon :cg.icon-pixmap :cg.item-list :cg.keyboard-shortcuts :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.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) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+M +t \"Console for Debugging\"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'default-init-function :on-restart 'do-default-restart) ;; End of Project Definition