cells-cvs

cells-cvs@common-lisp.net

721 discussions

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

13 Oct '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv1506 Modified Files: fm-utilities.lisp Log Message: --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/10/11 22:16:22 1.11 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/10/13 05:56:38 1.12 @@ -401,6 +401,11 @@ :global-search t :test ,test)) +(export! fmv) + +(defmacro fmv (name) + `(md-value (fm-other ,name))) + (defmacro fm-otherx (md-name &key (starting 'self) skip-tree) (if (eql starting 'self) `(or (fm-find-one ,starting ,(if (consp md-name)

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 11 Oct '06

11 Oct '06

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv31873/utils-kt Modified Files: detritus.lisp Log Message: --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/09/05 18:40:48 1.10 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/10/11 22:16:22 1.11 @@ -46,11 +46,23 @@ (defun xor (c1 c2) (if c1 (not c2) c2)) -(export! push-end) +(export! push-end collect collect-if) (defmacro push-end (item place ) `(setf ,place (nconc ,place (list ,item)))) +(defun collect (x list &key (key 'identity) (test 'eql)) + (loop for i in list + when (funcall test x (funcall key i)) + collect i)) + +(defun collect-if (test list) + (loop for i in list + when (funcall test i) + collect i)) + + + ;;; --- FIFO Queue ----------------------------- (defun make-fifo-queue (&rest init-data)

1 0

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

11 Oct '06

Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv31873/gui-geometry Modified Files: geo-family.lisp geometer.lisp Log Message: --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/07/06 22:10:02 1.6 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2006/10/11 22:16:22 1.7 @@ -38,8 +38,9 @@ (pr lk) 0))))) :lb (c? (+ (- (^outset)) (ecase (orientation self) - (:vertical (bif (lk (last1 (^kids))) - (pb lk) 0)) + (:vertical (loop for k in (^kids) + unless (collapsed k) + maximizing (pb k))) (:horizontal (downs (loop for k in (^kids) maximizing (l-height k))))))) :kid-slots (lambda (self) --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/08/21 04:29:31 1.8 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2006/10/11 22:16:22 1.9 @@ -224,6 +224,8 @@ ;---------------------------------- +(export! geo-kid-wrap) + (defun geo-kid-wrap (self bound) (funcall (ecase bound ((pl pb) '-)((pr pt) '+)) (funcall (ecase bound

1 0

[cells-cvs] CVS cells
by ktilton 11 Oct '06

11 Oct '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv31873 Modified Files: cells-manifesto.txt fm-utilities.lisp propagate.lisp Log Message: --- /project/cells/cvsroot/cells/cells-manifesto.txt 2006/10/02 02:38:31 1.9 +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2006/10/11 22:16:20 1.10 @@ -267,8 +267,8 @@ -- kid-slotting: used almost exclusively so far for orderly GUI layout, a parent must be able to specify rules for specific slots of kids. Example: a "stack" class wants to provide rules for child geometry specifying left, right, or centered alignment and vertical stacking (with optional spacing) one below -the other. The idea is that we want to other child instances without worrying about how they will -be arranged in some container. +the other. The idea is that we want to author classes of what might be GUI subcomponents without worrying +about how they will be arranged in some container. -- finalization: when an instance appears in the "old kids" but not in the "new kids", a Cells engine may need to arrange for all Cells to "unsubscribe" from their dependents. Cells takes care of that if @@ -367,11 +367,11 @@ deferred until all computed cells are up-to-date with the current state of the universe." -_______________ -Uncommentary :) +_____________ +Uncommentary -- Peter Seibel, comp.lang.lisp: -"I couldn't find anything that explained what it was and why I should care." +"I couldn't find anything that explained what [Cells] was and why I should care." -- Alan Crowe, comp.lang.lisp: "Further confession: I'm bluffing. I've grasped that Cells is --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/10/02 02:38:31 1.10 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/10/11 22:16:22 1.11 @@ -44,6 +44,11 @@ (defmacro upper (self &optional (type t)) `(container-typed ,self ',type)) +(export! u^) + +(defmacro u^ (type) + `(upper self ,type)) + (defmethod container (self) (fm-parent self)) (defmethod container-typed ((self model-object) type) --- /project/cells/cvsroot/cells/propagate.lisp 2006/10/02 02:38:31 1.22 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/10/11 22:16:22 1.23 @@ -101,7 +101,7 @@ (md-slot-owning (type-of (c-model c)) (c-slot-name c))) (flet ((listify (x) (if (listp x) x (list x)))) (bwhen (lost (set-difference (listify prior-value) (listify (c-value c)))) - (trc "prop nailing owned" c (c-value c) prior-value lost) + (trc nil "prop nailing owned" c (c-value c) prior-value lost) (mapcar 'not-to-be lost)))) ; ; with propagation done, ephemerals can be reset. we also do this in c-awaken, so

1 0

[cells-cvs] CVS cells
by ktilton 06 Oct '06

06 Oct '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv7005 Modified Files: trc-eko.lisp Log Message: --- /project/cells/cvsroot/cells/trc-eko.lisp 2006/09/03 13:41:09 1.2 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2006/10/06 08:01:10 1.3 @@ -46,6 +46,17 @@ (count-it :trcfailed))) (count-it :tgtnileval))))))) +(export! trcx) + +(defmacro trcx (tgt-form &rest os) + (if (eql tgt-form 'nil) + '(progn) + `(without-c-dependency + (call-trc t ,(format nil "TX> ~(~a~)" tgt-form) + ,@(loop for obj in os + nconcing (list (format nil "~a:" obj) obj)))))) + + (defparameter *last-trc* (get-internal-real-time)) (defun call-trc (stream s &rest os) @@ -58,7 +69,7 @@ (format stream "~a" s) (let (pkwp) (dolist (o os) - (format stream (if pkwp " ~(~s~)" " __ ~(~s~)") o) + (format stream (if pkwp " ~(~s~)" " ~(~s~)") o) ;; save, used to insert divider, trcx dont like (setf pkwp (keywordp o)))) (force-output stream) (values))

1 0

[cells-cvs] CVS cells
by ktilton 02 Oct '06

02 Oct '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv16659 Modified Files: cell-types.lisp link.lisp Log Message: lose mathx package refs --- /project/cells/cvsroot/cells/cell-types.lisp 2006/10/02 02:38:31 1.18 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/10/02 20:55:00 1.19 @@ -46,9 +46,9 @@ (defun caller-drop (used caller) (fifo-delete (c-caller-store used) caller)) -(defmethod trcp ((c cell)) - (and #+not(typep (c-model c) 'index) - (find (c-slot-name c) '(mathx::line-breaks mathx::phrases)))) +;;;(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/link.lisp 2006/08/21 04:29:30 1.17 +++ /project/cells/cvsroot/cells/link.lisp 2006/10/02 20:55:00 1.18 @@ -58,8 +58,8 @@ (defun c-unlink-unused (c &aux (usage (cd-usage c)) (usage-size (array-dimension (cd-usage c) 0)) - (dbg nil #+not (and (typep (c-model c) 'mathx::mx-solver-stack) - (eq (c-slot-name c) '.kids)))) + (dbg nil)) ;; #+not (and (typep (c-model c) 'mathx::mx-solver-stack) + ;;(eq (c-slot-name c) '.kids)))) (declare (ignorable usage-size)) (when (cd-useds c) (let (rev-pos)

1 0

[cells-cvs] CVS Celtk
by ktilton 02 Oct '06

02 Oct '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv27482 Modified Files: Celtk.lisp composites.lisp run.lisp togl.lisp widget.lisp Log Message: --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/09/05 18:43:22 1.35 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/10/02 02:56:01 1.36 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.35 2006/09/05 18:43:22 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.36 2006/10/02 02:56:01 ktilton Exp $ (defpackage :celtk (:nicknames "CTK") @@ -103,31 +103,6 @@ (trc nil "!!! --- tk-user-queue-handler dispatching" defer-info) (funcall task))) -(defun replace-char (txt char with) - (let ((pos (search char txt))) - (loop - while pos - do - (progn - ;;(dbg "txt: ~a -> " txt) - (setf txt (concatenate 'string (subseq txt 0 pos) with (subseq txt (1+ pos)))) - ;;(dbg " ~a~&" txt) - (setf pos (search char txt :start2 (+ pos (length with))))))) - txt) - -(defun tkescape (txt) - (setf txt (format nil "~a" txt)) - (replace-char - (replace-char - (replace-char - (replace-char - (replace-char - txt "\\" "\\\\") - "$" "\\$") - "[" "\\[") - "]" "\\]") - "\"" "\\\"")) - (defun tk-format-now (fmt$ &rest fmt-args) (unless (find *tkw* *windows-destroyed*) (let* ((*print-circle* nil) --- /project/cells/cvsroot/Celtk/composites.lisp 2006/09/29 16:08:31 1.18 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/10/02 02:56:01 1.19 @@ -32,7 +32,7 @@ ;;; --- decoration ------------------------------------------- (defmd decoration-mixin () - (decoration (c-in :normal))) + (decoration (c-in nil))) ;;; --- toplevel --------------------------------------------- @@ -113,6 +113,9 @@ on-key-down on-key-up) +(defmethod make-tk-instance ((self window)) + (setf (gethash (^path) (dictionary .tkw)) self)) + (defun screen-width () (let ((*tkw* *tkw*)) (tk-format-now "winfo screenwidth ."))) @@ -133,6 +136,7 @@ (tk-format '(:pre-make-tk self) "wm overrideredirect . yes") ) + (defmethod do-on-key-down :before (self &rest args &aux (keysym (car args))) (trc nil "ctk::do-on-key-down window" keysym (keyboard-modifiers .tkw)) (bwhen (mod (keysym-to-modifier keysym)) @@ -148,6 +152,7 @@ ;;; Helper function that actually executes decoration change (defun %%do-decoration (widget decoration) + (break "hunh?") (let ((path (path widget))) (ecase decoration (:none (progn --- /project/cells/cvsroot/Celtk/run.lisp 2006/09/05 18:43:22 1.20 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/10/02 02:56:01 1.21 @@ -18,6 +18,8 @@ (in-package :Celtk) + + ;;; --- running a Celtk (window class, actually) -------------------------------------- (eval-now! @@ -66,6 +68,8 @@ (tcl-do-one-event-loop)) + + (defun ensure-destruction (w) (TRC nil "ensure-destruction entry" W) (unless (find w *windows-being-destroyed*) --- /project/cells/cvsroot/Celtk/togl.lisp 2006/09/05 18:43:22 1.20 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/10/02 02:56:01 1.21 @@ -90,8 +90,12 @@ (togl-timer-func (callback togl-timer)) ;; probably want to make this optional ) +(export! togl-ptr-set ^togl-ptr-set) + (deftk togl (widget) - ((togl-ptr :cell nil :initform nil :initarg :togl-ptr :accessor togl-ptr) + ((togl-ptr :cell nil :initform nil :initarg :togl-ptr :accessor togl-ptr) + (togl-ptr-set :initform (c-in nil) :initarg :togl-ptr-set :accessor togl-ptr-set + :documentation "very complicated, don't ask (togl-ptr cannot wait on ufb processing)") (cb-create :initform nil :initarg :cb-create :reader cb-create) (cb-display :initform nil :initarg :cb-display :reader cb-display) (cb-reshape :initform nil :initarg :cb-reshape :reader cb-reshape) @@ -150,6 +154,11 @@ :id (gentemp "TOGL") :ident (c? (^path)))) +(export! togl-redisp) +(defun togl-redisp (togl) + (when (togl-ptr togl) + (togl-post-redisplay (togl-ptr togl)))) + (defmacro with-togl ((togl-form width-var height-var) &body body &aux (togl-ptr (gensym))) `(let* ((,togl-ptr (togl-ptr ,togl-form)) (*tki* (togl-interp ,togl-ptr)) @@ -184,10 +193,11 @@ (defmethod ,(intern uc$) ((self togl)))))) (def-togl-callback create () - (trc "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr ) + (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) - (setf (togl-ptr self) togl-ptr) + (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)) (def-togl-callback display ()) @@ -198,7 +208,6 @@ (defmethod make-tk-instance ((self togl)) (with-integrity (:client `(:make-tk ,self)) (setf (gethash (^path) (dictionary .tkw)) self) + (trc "making togl!!!!!!!!!!!!" (path self)(tk-configurations self)) (tk-format-now "togl ~a ~{~(~a~) ~a~^ ~}" (path self)(tk-configurations self)))) - ;; this leads to "togl <path> [-<config option> <value]*", in turn to togl_create - --- /project/cells/cvsroot/Celtk/widget.lisp 2006/08/21 04:30:23 1.17 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/10/02 02:56:01 1.18 @@ -87,8 +87,6 @@ (get-callback callback-name) self-tkwin))) - - (defun widget-menu (self key) (or (find key (^menus) :key 'md-name) (break "The only menus I see are~{ ~a,~} not requested ~a" (mapcar 'md-name (^menus)) key))) @@ -106,10 +104,9 @@ (setf (gethash (^path) (dictionary .tkw)) self) (trc nil "mktki" self (^path)) (with-integrity (:client `(:make-tk ,self)) - (when (tk-class self) - (tk-format-now "~(~a~) ~a ~{~(~a~) ~a~^ ~}" ;; call to this GF now integrity-wrapped by caller - (tk-class self) (path self)(tk-configurations self))) - #+tryinafter (tkwin-register self))) + (when (tk-class self) + (tk-format-now "~(~a~) ~a ~{~(~a~) ~a~^ ~}" ;; call to this GF now integrity-wrapped by caller + (tk-class self) (path self)(tk-configurations self))))) (defmethod make-tk-instance :after ((self widget)) (with-integrity (:client `(:post-make-tk ,self)) @@ -266,7 +263,7 @@ (defobserver image-files () (loop for (name file-pathname) in (set-difference new-value old-value :key 'car) do (tk-format `(:pre-make-tk ,self) "image create photo ~(~a.~a~) -file {~a}" - (^path) name (progn #+not tkescape (namestring file-pathname))))) + (^path) name (namestring file-pathname)))) ;;; --- menus ---------------------------------

1 0

[cells-cvs] CVS Celtk/gears
by ktilton 02 Oct '06

02 Oct '06

Update of /project/cells/cvsroot/Celtk/gears In directory clnet:/tmp/cvs-serv27482/gears Modified Files: gears.lpr Log Message: --- /project/cells/cvsroot/Celtk/gears/gears.lpr 2006/05/26 17:50:36 1.1 +++ /project/cells/cvsroot/Celtk/gears/gears.lpr 2006/10/02 02:56:01 1.2 @@ -1,11 +1,12 @@ -;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- (in-package :cg-user) (defpackage :GEARS) (define-project :name :gears - :modules (list (make-instance 'module :name "gears.lisp")) + :modules (list (make-instance 'module :name "gears.lisp") + (make-instance 'module :name "nehe-02")) :projects (list (make-instance 'project-module :name "..\\CELTK") (make-instance 'project-module :name "C:\\1-devtools\\cl-opengl\\glu")) @@ -77,7 +78,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'gears::gears + :on-initialization 'gears::nehe-02 :on-restart 'do-default-restart) ;; End of Project Definition

1 0

[cells-cvs] CVS cells
by ktilton 02 Oct '06

02 Oct '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv23239 Modified Files: cell-types.lisp cells-manifesto.txt cells.lisp constructors.lisp defmodel.lisp fm-utilities.lisp integrity.lisp md-slot-value.lisp model-object.lisp propagate.lisp Log Message: Hope I have not broken things, but consider this a warning: I may have. --- /project/cells/cvsroot/cells/cell-types.lisp 2006/07/25 10:51:48 1.17 +++ /project/cells/cvsroot/cells/cell-types.lisp 2006/10/02 02:38:31 1.18 @@ -25,12 +25,13 @@ inputp ;; t for old c-variable class synaptic - changed (caller-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify callers FIFO (state :nascent :type symbol) ;; :nascent, :awake, :optimized-away (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :valid} (pulse 0 :type fixnum) + (pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP + lazy debug md-info) @@ -46,9 +47,8 @@ (fifo-delete (c-caller-store used) caller)) (defmethod trcp ((c cell)) - #+not (and ;; (typep (c-model c) 'index) - (find (c-slot-name c) '(celtk::state mathx::problem)))) - + (and #+not(typep (c-model c) 'index) + (find (c-slot-name c) '(mathx::line-breaks mathx::phrases)))) ; --- ephemerality -------------------------------------------------- ; @@ -86,16 +86,12 @@ (defstruct (c-ruled (:include cell) (:conc-name cr-)) - lazy (code nil :type list) ;; /// feature this out on production build rule) (defun c-optimized-away-p (c) (eql :optimized-away (c-state c))) -(defmethod c-lazy ((c c-ruled)) (cr-lazy c)) -(defmethod c-lazy (c) (declare (ignore c)) nil) - ;---------------------------- (defmethod trcp-slot (self slot-name) --- /project/cells/cvsroot/cells/cells-manifesto.txt 2006/06/29 09:54:06 1.8 +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2006/10/02 02:38:31 1.9 @@ -13,7 +13,7 @@ he had to propagate that change to other cells by first remembering which other ones included the changed cell in their computation. Then he had to do the calculations for those, erase, enter... -and then repeating that process to propagate those changes in a +and then repeat that process to propagate those changes in a cascade across the paper. VisiCalc let my father take the formula he had in mind and @@ -61,7 +61,7 @@ way around it, and thus his prediction that a software silver bullet was in principle impossible. -Which brings us to Cells. See also [axiom] Phillip Eby's developiong axiomatic +Which brings us to Cells. See also [axiom] Phillip Eby's developing axiomatic definition he is developing in support of Ryan Forseth's SoC project. DEFMODEL and Slot types @@ -236,8 +236,8 @@ Let's return for a moment to VisiCalc and its descendants. In even the most complex financial spreadsheet model, no one cell rule accesses more than a relatively few other spreadsheet cells (counting a row or column range as one reference). Yet the complex model emerges. All the work of tracking dependencies -is handled by the spreadsheet software, which require no special declaration by the modeller. They simply -writes the Cell rule. In writing the rule, they are concerned only with the derivation of one datapoint from +is handled by the spreadsheet software, which requires no special declaration by the modeller. They simply +write the Cell rule. In writing the rule, they are concerned only with the derivation of one datapoint from a population of other datapoints. No effort goes into arranging for the rule to get run at the right time, and certainly no energy is spent worrying about what other cells might be using the authored cell. That cell has certain semantics -- "account balance", perhaps -- and the modeller need only worry about writing @@ -251,8 +251,8 @@ Model Building -------------- -Everything above could describe one instance of one class defined by DEFMODEL. Of course, we want multiples -of both. In brief: +Everything above could describe one instance of one class defined by DEFMODEL. A real application has +multiple instances of multiple classes. So... -- cells can depend on other cells from any other instance. Since a rule gets passed only "self", Cell users need something like the Family class included with the Cells package effectively to turn a collection of @@ -312,6 +312,7 @@ The dataflow paradigm: http://en.wikipedia.org/wiki/Dataflow Reactive programming: http://www.haskell.org/yampa/AFPLectureNotes.pdf Frame-based programming + Definitive-programming Commentary ---------- --- /project/cells/cvsroot/cells/cells.lisp 2006/08/21 04:29:30 1.16 +++ /project/cells/cvsroot/cells/cells.lisp 2006/10/02 02:38:31 1.17 @@ -25,7 +25,6 @@ (defparameter *causation* nil) (defparameter *data-pulse-id* 0) -(defparameter *data-pulses* nil) (defparameter *c-debug* nil) (defparameter *defer-changes* nil) @@ -33,12 +32,12 @@ (defparameter *client-queue-handler* nil) (defparameter *unfinished-business* nil) -(defun cells-reset (&optional client-queue-handler) +(defun cells-reset (&optional client-queue-handler &key debug) (utils-kt-reset) (setf + *c-debug* debug *c-prop-depth* 0 *data-pulse-id* 0 - *data-pulses* nil *defer-changes* nil ;; should not be necessary, but cannot be wrong *client-queue-handler* client-queue-handler *within-integrity* nil --- /project/cells/cvsroot/cells/constructors.lisp 2006/07/06 22:10:01 1.8 +++ /project/cells/cvsroot/cells/constructors.lisp 2006/10/02 02:38:31 1.9 @@ -48,11 +48,19 @@ (defmacro c?n (&body body) `(make-c-dependent - :code nil ;; `(without-c-dependency ,@,body) + :code '(without-c-dependency ,@body) :inputp t :value-state :unevaluated :rule (c-lambda (without-c-dependency ,@body)))) +(export! c?once) +(defmacro c?once (&body body) + `(make-c-dependent + :code '(without-c-dependency ,@body) + :inputp nil + :value-state :unevaluated + :rule (c-lambda (without-c-dependency ,@body)))) + (defmacro c?dbg (&body body) `(make-c-dependent :code ',body --- /project/cells/cvsroot/cells/defmodel.lisp 2006/09/05 18:40:47 1.9 +++ /project/cells/cvsroot/cells/defmodel.lisp 2006/10/02 02:38:31 1.10 @@ -20,6 +20,7 @@ (defmacro defmodel (class directsupers slotspecs &rest options) ;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object))) + (assert (not (find class directsupers))() "~a cannot be its own superclass" class) `(progn (eval-when (:compile-toplevel :execute :load-toplevel) (setf (get ',class :cell-types) nil)) @@ -34,94 +35,87 @@ &allow-other-keys) slotspec - (declare (ignorable slotargs)) + (declare (ignorable slotargs owning)) (list (when cell (let* ((reader-fn (or reader accessor)) - (deriver-fn (intern$ "^" (symbol-name reader-fn))) - ) - ; - ; may as well do this here... - ; - ;;(trc nil "slot, deriverfn would be" slotname deriverfn) + (deriver-fn (intern$ "^" (symbol-name reader-fn)))) `(eval-when (:compile-toplevel :execute :load-toplevel) - (setf (md-slot-cell-type ',class ',slotname) ,cell) (unless (macro-function ',deriver-fn) (defmacro ,deriver-fn () - `(,',reader-fn self)))))) - (when owning - `(eval-when (:compile-toplevel :execute :load-toplevel) - (setf (md-slot-owning ',class ',slotname) ,owning))))))) - - ; - ; ------- defclass --------------- (^slot-value ,model ',',slotname) - ; - - (progn - (defclass ,class ,(or directsupers '(model-object));; now we can def the class - ,(mapcar (lambda (s) - (list* (car s) - (let ((ias (cdr s))) - ;; We handle accessor below - (when (getf ias :cell t) - (remf ias :reader) - (remf ias :writer) - (remf ias :accessor)) - (remf ias :cell) - (remf ias :owning) - (remf ias :unchanged-if) - ias))) (mapcar #'copy-list slotspecs)) - (:documentation - ,@(or (cdr (find :documentation options :key #'car)) - '("chya"))) - (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this - ,@(cdr (find :default-initargs options :key #'car))) - (:metaclass ,(or (cadr (find :metaclass options :key #'car)) - 'standard-class))) - - (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key) - (declare (ignore slot-names iargs)) - ,(when (and directsupers (not (member 'model-object directsupers))) - `(unless (typep self 'model-object) - (error "If no superclass of ~a inherits directly + `(,',reader-fn self)))))))))) + + ; + ; ------- defclass --------------- (^slot-value ,model ',',slotname) + ; + + (progn + (defclass ,class ,(or directsupers '(model-object));; now we can def the class + ,(mapcar (lambda (s) + (list* (car s) + (let ((ias (cdr s))) + ;; We handle accessor below + (when (getf ias :cell t) + (remf ias :reader) + (remf ias :writer) + (remf ias :accessor)) + (remf ias :cell) + (remf ias :owning) + (remf ias :unchanged-if) + ias))) (mapcar #'copy-list slotspecs)) + (:documentation + ,@(or (cdr (find :documentation options :key #'car)) + '("chya"))) + (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this + ,@(cdr (find :default-initargs options :key #'car))) + (:metaclass ,(or (cadr (find :metaclass options :key #'car)) + 'standard-class))) + + (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key) + (declare (ignore slot-names iargs)) + ,(when (and directsupers (not (member 'model-object directsupers))) + `(unless (typep self 'model-object) + (error "If no superclass of ~a inherits directly or indirectly from model-object, model-object must be included as a direct super-class in the defmodel form for ~a" ',class ',class)))) - ; - ; slot accessors once class is defined... - ; - ,@(mapcar (lambda (slotspec) - (destructuring-bind - (slotname &rest slotargs - &key (cell t) unchanged-if (accessor slotname) reader writer type - &allow-other-keys) - slotspec - - (declare (ignorable slotargs)) - (when cell - (let* ((reader-fn (or reader accessor)) - (writer-fn (or writer accessor)) - ) - (setf (md-slot-cell-type class slotname) cell) - - `(progn - ,(when reader-fn - `(defmethod ,reader-fn ((self ,class)) - (md-slot-value self ',slotname))) - - ,(when writer-fn - `(defmethod (setf ,writer-fn) (new-value (self ,class)) - (setf (md-slot-value self ',slotname) - ,(if type - `(coerce new-value ',type) - 'new-value)))) + ; + ; slot accessors once class is defined... + ; + ,@(mapcar (lambda (slotspec) + (destructuring-bind + (slotname &rest slotargs + &key (cell t) owning unchanged-if (accessor slotname) reader writer type + &allow-other-keys) + slotspec + + (declare (ignorable slotargs)) + (when cell + (let* ((reader-fn (or reader accessor)) + (writer-fn (or writer accessor)) + ) + `(progn + (setf (md-slot-cell-type ',class ',slotname) ,cell) - ,(when unchanged-if - `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)) - ) - )) - )) - slotspecs) - (find-class ',class)))) + ,(when owning + `(setf (md-slot-owning ',class ',slotname) ,owning)) + ,(when reader-fn + `(defmethod ,reader-fn ((self ,class)) + (md-slot-value self ',slotname))) + + ,(when writer-fn + `(defmethod (setf ,writer-fn) (new-value (self ,class)) + (setf (md-slot-value self ',slotname) + ,(if type + `(coerce new-value ',type) + 'new-value)))) + + ,(when unchanged-if + `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)) + ) + )) + )) + slotspecs) + (find-class ',class)))) (defun defmd-canonicalize-slot (slotname &key --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/08/31 17:35:28 1.9 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/10/02 02:38:31 1.10 @@ -118,9 +118,9 @@ max)) -(defun fm-traverse (family applied-fn &key skip-node skip-tree global-search opaque) +(defun fm-traverse (family applied-fn &key skip-node skip-tree global-search opaque with-dependency) ;;(when *fmdbg* (trc "fm-traverse" family skipTree skipNode global-search)) - (without-c-dependency + (when family (labels ((tv-family (fm) (etypecase fm @@ -134,13 +134,18 @@ (tv-family kid)) ;(tv-family (mdValue fm)) ))))))) - (tv-family family) - (when global-search - (fm-traverse (fm-parent family) applied-fn - :global-search t - :skip-tree family - :skip-node skip-node)))) - nil)) + (flet ((tv () + (tv-family family) + (when global-search + (fm-traverse (fm-parent family) applied-fn + :global-search t + :skip-tree family + :skip-node skip-node + :with-dependency t)))) ;; t actually just defaults to outermost call + (if with-dependency + (tv) + (without-c-dependency (tv)))))) + (values)) (defun fm-ordered-p (n1 n2 &aux (top (fm-ascendant-common n1 n2))) (assert top) --- /project/cells/cvsroot/cells/integrity.lisp 2006/07/24 05:03:08 1.12 +++ /project/cells/cvsroot/cells/integrity.lisp 2006/10/02 02:38:31 1.13 @@ -30,6 +30,12 @@ "Invalid second value to with-integrity: ~a" opcode)) `(call-with-integrity ,opcode ,defer-info (lambda () ,@body))) +(export! with-c-change) + +(defmacro with-c-change (id &body body) + `(with-integrity (:change ,id) + ,@body)) + (defun integrity-managed-p () *within-integrity*) @@ -53,23 +59,6 @@ (funcall action) (finish-business))))) -(export! with-integrity-bubble) - -(defmacro with-integrity-bubble ((&optional dbg-info) &rest body) - "Whimsical name for launching a self-contained, dynamic integrity chunk, as with -string-to-mx in the math-paper project, where everything is fully isolated from the -outside computation." - `(call-with-integrity-bubble ,dbg-info (lambda () ,@body))) - -(defun call-with-integrity-bubble (dbg-info action) - (declare (ignorable dbg-info)) - (let ((*within-integrity* nil) - *unfinished-business* - *defer-changes* - *call-stack* - (*data-pulse-id* 0)) - (funcall action))) - (defun ufb-queue (opcode) (assert (find opcode *ufb-opcodes*)) (cdr (assoc opcode *unfinished-business*))) @@ -115,9 +104,13 @@ ; we do not go back to check for a need to :tell-dependents because (a) the original propagation ; and processing of the :tell-dependents queue is a full propagation; no rule can ask for a cell that ; then decides it needs to recompute and possibly propagate; and (b) the only rules forced awake during - ; awakening need that precisely because no one asked for their values, so their can be no dependents + ; awakening need that precisely because no one asked for their values, so there can be no dependents ; to "tell". I think. :) So... ; + (when (fifo-peek (ufb-queue :tell-dependents)) + (DOlist (b (fifo-data (ufb-queue :tell-dependents))) + (trc "unhandled :tell-dependents" (car b) (c-callers (car b)))) + (break "ufb")) (assert (null (fifo-peek (ufb-queue :tell-dependents)))) ;--- process client queue ------------------------------ --- /project/cells/cvsroot/cells/md-slot-value.lisp 2006/08/21 04:29:30 1.27 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2006/10/02 02:38:31 1.28 @@ -55,8 +55,10 @@ (declare (ignorable debug-id caller)) (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))) (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 ;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete @@ -64,17 +66,27 @@ ((c-inputp c)(trc nil "c-inputp" c)) ;; always current (for now; see above) ((or (not (c-validp c)) - (some (lambda (used) - (ensure-value-is-current used :nested c) - (trc nil "comparing pulses (caller, used, used-changed): " c used (c-changed used)) - (when (and (c-changed used) (> (c-pulse used)(c-pulse c))) - (trc nil "used changed and newer !!!!!!" c used) - t)) - (cd-useds c))) - (trc nil "ensuring current calc-set of" (c-slot-name c)) + ;; + ;; new for 2006-09-21: a cell ended up checking slots of a dead instance, which would have been + ;; refreshed when checked, but was going to be checked last because it was the first used, useds + ;; being simply pushed onto a list as they come up. We may need fancier handling of dead instance/cells + ;; still being encountered by consulting the prior useds list, but checking now in same order as + ;; accessed seems Deeply Correct (and fixed the immediate problem nicely, always a Good Sign). + ;; + (labels ((check-reversed (useds) + (when useds + (or (check-reversed (cdr useds)) + (let ((used (car useds))) + (ensure-value-is-current used :nested c) + (trc nil "comparing pulses (caller, used, used-changed): " c debug-id used (c-pulse-last-changed used)) + (when (> (c-pulse-last-changed used)(c-pulse c)) + (trc nil "used changed and newer !!!!!!" c debug-id used) + t)))))) + (check-reversed (cd-useds c)))) + (trc nil "kicking off calc-set of" (c-slot-name c) :pulse *data-pulse-id*) (calculate-and-set c)) - (t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) ) + (t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) debug-id) (c-pulse-update c :valid-uninfluenced))) (when (c-unboundp c) @@ -157,7 +169,7 @@ ; --- data flow propagation ----------- ; - (setf (c-changed c) t) + (setf (c-pulse-last-changed c) *data-pulse-id*) (without-c-dependency (c-propagate c prior-value t))))))) @@ -178,11 +190,16 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s" slot-name self (slot-value self slot-name))) - (when *defer-changes* + (cond + ((find (c-lazy c) '(:once-asked :always t)) + (md-slot-value-assume c new-value nil)) + + (*defer-changes* (c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c)) - (with-integrity (:change) - (md-slot-value-assume c new-value nil)) + (t + (with-integrity (:change slot-name) + (md-slot-value-assume c new-value nil)))) ;; new-value ;; above line commented out 2006-05-01. It seems to me we want the value assumed by the slot @@ -222,7 +239,7 @@ ; --- data flow propagation ----------- (unless (eq propagation-code :no-propagate) (trc nil "md-slot-value-assume flagging as changed" c) - (setf (c-changed c) t) + (setf (c-pulse-last-changed c) *data-pulse-id*) (c-propagate c prior-value (eq prior-state :valid))) ;; until 06-02-13 was (not (eq prior-state :unbound)) absorbed-value))) --- /project/cells/cvsroot/cells/model-object.lisp 2006/09/05 18:40:47 1.11 +++ /project/cells/cvsroot/cells/model-object.lisp 2006/10/02 02:38:31 1.12 @@ -25,6 +25,7 @@ (defclass model-object () ((.md-state :initform :nascent :accessor md-state) ; [nil | :nascent | :alive | :doomed] + (.awaken-on-init-p :initform nil :initarg :awaken-on-init-p :accessor awaken-on-init-p) ; [nil | :nascent | :alive | :doomed] (.cells :initform nil :accessor cells) (.cells-flushed :initform nil :accessor cells-flushed :documentation "cells supplied but un-whenned or optimized-away") @@ -51,17 +52,22 @@ for sn = (slot-definition-name esd) for sv = (when (slot-boundp self sn) (slot-value self sn)) - ;; do (print (list self sn sv (typep sv 'cell))) + ;; do (print (list (type-of self) sn sv (typep sv 'cell))) when (typep sv 'cell) do (if (md-slot-cell-type (type-of self) sn) (md-install-cell self sn sv) (when *c-debug* - (trc "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv self sn)))) + (break "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv sn (type-of self))))) ; ; queue up for awakening ; - (with-integrity (:awaken self) - (md-awaken self)))) + (if (awaken-on-init-p self) + (md-awaken self) + (with-integrity (:awaken self) + (md-awaken self))) + )) + + (defun md-install-cell (self sn c &aux (c-isa-cell (typep c 'cell))) ; @@ -162,14 +168,18 @@ (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))) + (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 (setf (md-slot-cell-type class-name slot-name) (cdr entry))))))) + (return-from md-slot-cell-type (setf (md-slot-cell-type class-name slot-name) (cdr entry))))))) (defun (setf md-slot-cell-type) (new-type class-name slot-name) (let ((entry (assoc slot-name (get class-name :cell-types)))) (if entry - (setf (cdr entry) new-type) + (progn + (setf (cdr entry) new-type) + (loop for c in (mop: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))))) (defun md-slot-owning (class-name slot-name) @@ -182,11 +192,12 @@ (defun (setf md-slot-owning) (value class-name slot-name) (let ((entry (assoc slot-name (get class-name :ownings)))) (if entry - (setf (cdr entry) value) + (progn + (setf (cdr entry) value) + (loop for c in (mop: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))))) - - (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)) --- /project/cells/cvsroot/cells/propagate.lisp 2006/09/05 18:40:47 1.21 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/10/02 02:38:31 1.22 @@ -46,10 +46,10 @@ (defun c-pulse-update (c key) (declare (ignorable key)) - (trc nil "c-pulse-update updating" *data-pulse-id* c key) - (assert (>= *data-pulse-id* (c-pulse c))) - (setf (c-changed c) nil - (c-pulse c) *data-pulse-id*)) + (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*)) ;--------------- propagate ---------------------------- @@ -90,19 +90,19 @@ ; expected to have side-effects, so we want to propagate fully and be sure no rule ; wants a rollback before starting with the side effects. ; - (c-propagate-to-callers c) + (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) + (when (and prior-value-supplied prior-value (md-slot-owning (type-of (c-model c)) (c-slot-name c))) - (bwhen (lost (set-difference prior-value (c-value c))) - (trc "bingo!!!!! lost nailing" lost) - (break "go") - (typecase lost - (atom (not-to-be lost)) - (cons (mapcar 'not-to-be lost))))) + (flet ((listify (x) (if (listp x) x (list x)))) + (bwhen (lost (set-difference (listify prior-value) (listify (c-value c)))) + (trc "prop nailing owned" c (c-value c) prior-value lost) + (mapcar 'not-to-be lost)))) ; ; with propagation done, ephemerals can be reset. we also do this in c-awaken, so ; let the fn decide if C really is ephemeral. Note that it might be possible to leave @@ -113,8 +113,7 @@ ; would this be bad for persistent CLOS, in which a DB would think there was still a link ; between two records until the value actually got cleared? ; - (ephemeral-reset c) - )) + (ephemeral-reset c))) ; --- slot change ----------------------------------------------------------- @@ -177,7 +176,7 @@ (let ((*causation* causation)) (trc nil "c-propagate-to-callers > actually notifying callers of" c (mapcar 'c-slot-name (c-callers c))) (dolist (caller (c-callers c)) - (unless (member (cr-lazy caller) '(t :always :once-asked)) + (unless (member (c-lazy caller) '(t :always :once-asked)) (trc nil "propagating to caller is caller:" caller) (ensure-value-is-current caller :prop-from c))))))))

1 0

[cells-cvs] CVS cells/gui-geometry
by ktilton 02 Oct '06

02 Oct '06

Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv23239/gui-geometry Modified Files: gui-geometry.lpr Log Message: Hope I have not broken things, but consider this a warning: I may have. --- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/08/21 04:29:31 1.4 +++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.lpr 2006/10/02 02:38:32 1.5 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Aug 17, 2006 12:24)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*- (in-package :cg-user)

1 0

← Newer
1
...
24
25
26
27
28
29
30
...
73
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs