cells-cvs

cells-cvs@common-lisp.net

721 discussions

[cells-cvs] CVS cells
by ktilton 22 Apr '08

22 Apr '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv31764 Modified Files: defmodel.lisp family.lisp md-slot-value.lisp md-utilities.lisp model-object.lisp propagate.lisp Log Message: --- /project/cells/cvsroot/cells/defmodel.lisp 2008/03/17 20:34:45 1.18 +++ /project/cells/cvsroot/cells/defmodel.lisp 2008/04/22 10:11:50 1.19 @@ -103,7 +103,7 @@ `(eval-when (#-sbcl :compile-toplevel :load-toplevel :execute) ; ph -- prevent sbcl warning (setf (md-slot-cell-type ',class ',slotname) ,cell) ,(when owning - `(setf (md-slot-owning ',class ',slotname) ,owning)) + `(setf (md-slot-owning? ',class ',slotname) ,owning)) ,(when reader-fn `(defmethod ,reader-fn ((self ,class)) (md-slot-value self ',slotname))) --- /project/cells/cvsroot/cells/family.lisp 2008/04/11 14:00:14 1.26 +++ /project/cells/cvsroot/cells/family.lisp 2008/04/22 10:11:50 1.27 @@ -19,7 +19,7 @@ (in-package :cells) (eval-when (:compile-toplevel :execute :load-toplevel) - (export '(model value family dbg + (export '(model value family dbg .pa kids kid1 ^k1 kid2 ^k2 last-kid ^k-last perishable))) (defmodel model () @@ -47,6 +47,7 @@ (or (md-name self) (type-of self)))) (define-symbol-macro .parent (fm-parent self)) +(define-symbol-macro .pa (fm-parent self)) (defmethod md-name (other) (trc "yep other md-name" other (type-of other)) @@ -180,11 +181,7 @@ (defmethod kids ((other model-object)) nil) -(defmethod not-to-be :before ((fm family)) - (let ((sv-kids (slot-value fm '.kids))) - (when (listp sv-kids) - (dolist ( kid sv-kids) - (not-to-be kid))))) + ;------------------ kid slotting ---------------------------- ; --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/20 13:04:40 1.45 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/22 10:11:50 1.46 @@ -69,12 +69,13 @@ (defvar *trc-ensure* nil) -(defun ensure-value-is-current (c debug-id ensurer) +(defmethod 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 ; dependencies are up-to-date before deciding if it itself is up-to-date ; (declare (ignorable debug-id ensurer)) + (count-it :ensure-value-is-current) ;; (trc c "ensure-value-is-current > entry" c (c-state c) :now-pulse *data-pulse-id* debug-id ensurer) --- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/20 13:04:40 1.19 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/22 10:11:50 1.20 @@ -40,26 +40,52 @@ nil)) (defgeneric not-to-be (self) + (:method ((self list)) + (dolist (s self) + (not-to-be s))) + (:method ((self array)) + (loop for s across self + do (not-to-be s))) + (:method ((self hash-table)) + (maphash (lambda (k v) + (declare (ignorable k)) + (not-to-be v)) self)) + (:method ((self model-object)) (md-quiesce self)) + + (:method :before ((self model-object)) + (loop for (slot-name . owning?) in (get (type-of self) :ownings) + when owning? + do (not-to-be (slot-value self slot-name)))) (:method :around ((self model-object)) (declare (ignorable self)) - (let ((*not-to-be* t)) - (trc nil #+not (typep self '(or mathx::problem mathx::prb-solvers mathx::prb-solver)) - "not.to-be nailing" self) - (unless (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))))) - + (let ((*not-to-be* t) + (dbg nil #+not (or (eq (md-name self) :eclm-owner) + (typep self '(or mathx::eclm-2008 clo:ix-form mathx::a1-panel mathx::edit-caret ctk:window))))) + + (flet ((gok () + (unless (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)) () + "Cell ~a of dead model ~a not quiesced. Was not-to-be shadowed by + a primary method? Use :before instead."))) ;; fails if user obstructs not.to-be with primary method (use :before etc) + + ))) + (if (not dbg) + (gok) + (wtrc (0 100 "not.to-be nailing" self (when (typep self 'family) + (mapcar 'type-of (slot-value self '.kids)))) + (gok) + (when dbg (trc "finished nailing" self)))))))) + (defun md-quiesce (self) (trc nil "md-quiesce nailing cells" self (type-of self)) (md-map-cells self nil (lambda (c) --- /project/cells/cvsroot/cells/model-object.lisp 2008/02/02 00:09:28 1.19 +++ /project/cells/cvsroot/cells/model-object.lisp 2008/04/22 10:11:50 1.20 @@ -216,7 +216,7 @@ do (setf (md-slot-cell-type (class-name c) slot-name) new-type))) (cdar (push (cons slot-name new-type) (get class-name :cell-types))))))) -(defun md-slot-owning (class-name slot-name) +(defun md-slot-owning? (class-name slot-name) (assert class-name) (if (eq class-name 'null) (get slot-name :owning) @@ -224,9 +224,9 @@ (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)))))))) + (return (setf (md-slot-owning? class-name slot-name) (cdr entry)))))))) -(defun (setf md-slot-owning) (value class-name slot-name) +(defun (setf md-slot-owning?) (value class-name slot-name) (assert class-name) (if (eq class-name 'null) (setf (get slot-name :owning) value) @@ -236,7 +236,7 @@ (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))) + do (setf (md-slot-owning? (class-name c) slot-name) value))) (push (cons slot-name value) (get class-name :ownings)))))) (defun md-slot-value-store (self slot-name new-value) --- /project/cells/cvsroot/cells/propagate.lisp 2008/03/15 15:18:34 1.34 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/04/22 10:11:50 1.35 @@ -105,7 +105,7 @@ ; (when (and prior-value-supplied prior-value - (md-slot-owning (type-of (c-model c)) (c-slot-name c))) + (md-slot-owning? (type-of (c-model c)) (c-slot-name c))) (trc nil "c.propagate> contemplating lost") (flet ((listify (x) (if (listp x) x (list x)))) (bif (lost (set-difference (listify prior-value) (listify (c-value c))))

1 0

[cells-cvs] CVS cells-gtk3/cells-gtk/test-gtk
by phildebrandt 20 Apr '08

20 Apr '08

Update of /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv29136/cells-gtk/test-gtk Modified Files: test-buttons.lisp test-drawing.lisp Log Message: now runs with the cells-store inside --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-buttons.lisp 2008/04/16 14:41:30 1.3 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-buttons.lisp 2008/04/20 13:05:03 1.4 @@ -4,42 +4,45 @@ ((nclics :accessor nclics :initform (c-in 0))) (:default-initargs :kids (c? (the-kids - (mk-label :text (c? (format nil "Toggled button active = ~a" - (with-widget (w :toggled-button) - (trc "calculating toggled button" w (value w)) - (value w))))) + (mk-label :text (c? (trc "### executing toggled button rule") + (format nil "Toggled button active = ~a" + (with-widget (w :toggled-button) + (trc " FOUND WIDGET" w (value w)) + (value w))))) (mk-hseparator) (mk-label :text (c? (format nil "Check button checked = ~a" - (widget-value :check-button)))) + (widget-value :check-button)))) (mk-hseparator) - (mk-label :text (c? (format nil "Radio button selected = ~a" - (with-widget (w :radio-group) - (value w))))) + (mk-label :text (c? (trc "### executing radio button rule") + (format nil "Radio button selected = ~a" + (with-widget (w :radio-group) + (trc " FOUND WIDGET") + (value w))))) (mk-hseparator) (mk-label :text (c? (format nil "Button clicked ~a times" - (nclics (upper self test-buttons)))) - :selectable t) + (nclics (upper self test-buttons)))) + :selectable t) (mk-hseparator) (mk-hbox :kids (c? (the-kids (mk-button :stock :apply - :tooltip "Click ....." - :on-clicked (callback (widget event data) - (incf (nclics (upper self test-buttons))))) + :tooltip "Click ....." + :on-clicked (callback (widget event data) + (incf (nclics (upper self test-buttons))))) (mk-button :label "Continuable error" - :on-clicked (callback (widget event data) - (trc "issuing continuable error" widget event) - (error 'gtk-continuable-error :text "Oops!"))) + :on-clicked (callback (widget event data) + (trc "issuing continuable error" widget event) + (error 'gtk-continuable-error :text "Oops!"))) (mk-button :label "Lisp error (Div 0)" - :on-clicked (callback (widget event data) + :on-clicked (callback (widget event data) (print (/ 3 0)))) (mk-toggle-button :md-name :toggled-button - :markup (c? (with-markup (:foreground (if (value self) :red :blue)) - "_Toggled Button"))) + :markup (c? (with-markup (:foreground (if (value self) :red :blue)) + "_Toggled Button"))) (mk-check-button :md-name :check-button - :markup (with-markup (:foreground :green) - "_Check Button"))))) + :markup (with-markup (:foreground :green) + "_Check Button"))))) (mk-hbox :md-name :radio-group :kids (kids-list? @@ -48,4 +51,11 @@ (mk-radio-button :md-name :radio-2 :label "Radio 2" :init t) (mk-radio-button :md-name :radio-3 - :label "Radio 3"))))))) + :label "Radio 3"))) + (mk-hbox + :kids (kids-list? + (mk-label :text (c? (trc "### executing toggled button rule 2") + (format nil "Toggled button active = ~a" + (with-widget (w :toggled-button) + (trc " FOUND WIDGET 2" w (value w)) + (value w))))))))))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing.lisp 2008/04/14 16:43:48 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing.lisp 2008/04/20 13:05:03 1.3 @@ -61,7 +61,7 @@ (col1 (random-color)) (col2 (random-color))) (trcx "rect" p1 p2 col1 col2) - (mk-primitive (fm-other :draw) :rectangle + (mk-primitive (find-widget :draw) :rectangle :p1 (c-in p1) :p2 (c-in p2) :rgb (rgb? col1) @@ -76,7 +76,7 @@ (radius (rnd 10 40)) (col1 (random-color)) (col2 (random-color))) - (mk-primitive (fm-other :draw) :arc + (mk-primitive (find-widget :draw) :arc :p (c-in p) :radius (c-in radius) :rgb (rgb? col1) @@ -99,7 +99,7 @@ 'cairo-drawing-area :md-name :draw-sun :expand t :fill t :width 500 :height 500 :fm-parent *parent* - :canvas (c? (let ((draw self)) + :canvas (c?n (let ((draw self)) (declare (ignorable draw)) (list (make-instance

1 0

[cells-cvs] CVS cells-gtk3/cells-gtk
by phildebrandt 20 Apr '08

20 Apr '08

Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv29136/cells-gtk Modified Files: buttons.lisp cairo-drawing-area.lisp dialogs.lisp drawing-area.lisp gtk-app.lisp tree-view.lisp widgets.lisp Log Message: now runs with the cells-store inside --- /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/16 14:41:28 1.3 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/20 13:05:02 1.4 @@ -59,11 +59,6 @@ (let ((state (gtk-toggle-button-get-active widget))) (setf (value self) state))))) -(defobserver .value ((self toggle-button)) - (trc "observing toggle-button .value" self (value self)) - (with-integrity (:change 'toggle-button-value) - (trc "with integrity"))) - #+test (DEF-GTK WIDGET TOGGLE-BUTTON (BUTTON) ((INIT :ACCESSOR INIT :INITARG :INIT :INITFORM NIL)) (MODE ACTIVE) (TOGGLED) :ACTIVE (C-IN NIL) :ON-TOGGLED --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/14 16:43:41 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/20 13:05:02 1.3 @@ -110,10 +110,10 @@ (defmodel cairo-drawing-area (drawing-area) ((cairo-context :accessor cairo-context :cell nil :initform nil) - (canvas :accessor canvas :cell t :initform (c-in nil) :initarg :canvas) - (.canvas :accessor .canvas :initform (c-in nil)) + (canvas :accessor canvas :initform (c-in nil) :initarg :canvas :owning t) + (.canvas :accessor .canvas :initform (c-in nil) :owning t) (prims :reader prims :initform (c? (append (canvas self) (.canvas self)))) - (widget :reader widget :cell t :initform (c? self)) + (widget :reader widget :initform (c? self)) ;; the primitive the mouse is currently hovering over (hover :accessor hover :cell nil :initform nil) (hover-history :accessor hover-history :cell nil :initform nil) @@ -122,7 +122,7 @@ ;; callback (on-dragged [widget] [button] [primtitive] [start] [end]) (on-dragged :accessor on-dragged :cell nil :initform nil :initarg :on-dragged) - (dragging :accessor dragging :cell t :initform (c-in nil)) + (dragging :accessor dragging :initform (c-in nil)) (drag-start :accessor drag-start :cell nil :initform nil) (drag-offset :accessor drag-offset :cell nil :initform nil) @@ -131,7 +131,7 @@ (selection-color :accessor selection-color :cell nil :initform '(1 1 .27)) (drag-threshold :accessor drag-threshold :cell nil :initform 3 :initarg :drag-threshold) - (selection :accessor selection :cell t :initform (c-in nil))) + (selection :accessor selection :initform (c-in nil))) (:default-initargs :on-pressed #'cairo-drawing-area-button-press :on-released #'cairo-drawing-area-button-release @@ -312,6 +312,11 @@ ;;;; ------ destroy methods ---------------------------------------------- +(defmethod not-to-be :before ((self cairo-drawing-area)) + (trc "not-to-be cairo-drawing area erasing everything" self) + (setf (canvas self) nil + (.canvas self) nil)) + (defgeneric remove-primitive (primitive) (:documentation "Removes primitive")) @@ -479,8 +484,12 @@ ((polar (2d:polar-coords (^delta))) (mouse-over-p (when (^widget) (with-accessors ((mouse mouse-pos)) (widget self) - (and (2d:point-in-box-p mouse (^p1) (^p2) :tol (line-width self)) - (< (2d:distance-point-line mouse (^p1) (^p2)) (* (^line-width) 2))))))) + (when-bind* ((p1 (^p1)) + (p2 (^p2)) + (line-width (^line-width))) + (and mouse + (2d:point-in-box-p mouse p1 p2 :tol line-width) + (< (2d:distance-point-line mouse p1 p2) (* line-width 2)))))))) :no-redraw (polar mouse-over-p))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/04/20 13:05:02 1.2 @@ -60,18 +60,23 @@ (defun show-dialog (dlg-class &rest inits) (let ((self (apply #'make-instance dlg-class :awaken-on-init-p t inits))) (wtrc (0 100 "processing dlg") - (let* ((response (gtk-dialog-run (id self))) - (result (funcall (fn-response self) self response))) + (let* ((response (wtrc (0 100 "running dialog") + (gtk-dialog-run (id self)))) + (result (funcall (fn-response self) self response))) + (trc "showed dialog" response result) (with-slots (content-area) self (when content-area (trc "reading content area" (value content-area)) (setf result (value content-area)) (trc "forgetting content-area") - (gtk-object-forget (id content-area) content-area))) - (trc "destroying self") - (gtk-widget-destroy (id self)) - (trc "forgetting self") - (gtk-object-forget (id self) self) + (not-to-be content-area) + #+not-necessary (gtk-object-forget (id content-area) content-area))) + (trc "destroying self (not-to-be)") + (not-to-be self) + #+not-necessary (progn + (gtk-widget-destroy (id self)) + (trc "forgetting self") + (gtk-object-forget (id self) self)) result)))) (defun show-message (text &rest inits) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/14 16:43:42 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/20 13:05:02 1.3 @@ -27,7 +27,7 @@ (def-widget drawing-area () ((mouse-pos :accessor mouse-pos :cell t :initform (c-in (2d:v 0 0))) - (canvas :accessor canvas :cell t :initform (c-in nil) :initarg :canvas) + (canvas :accessor canvas :cell t :initform (c-in nil) :initarg :canvas :owning t) ; (on-draw self) (on-draw :accessor on-draw :cell nil :initarg :on-draw :initform nil) ;n/a @@ -142,7 +142,8 @@ (defmethod redraw ((self drawing-area)) "Queues a redraw with GTK." (trc nil "queue redraw" self) - (gtk-widget-queue-draw (id self))) + (unless (mdead self) + (gtk-widget-queue-draw (id self)))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/16 14:41:28 1.4 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/20 13:05:02 1.5 @@ -187,7 +187,8 @@ :visible (c-in nil))) (gtk-window-set-auto-startup-notification nil) (to-be splash) - (setf (visible splash) t) + (with-integrity (:change :make-splash-visible) + (setf (visible splash) t)) (not-to-be (make-instance 'window)) ; kick gtk ... ugly (loop while (gtk-events-pending) do (gtk-main-iteration))))) @@ -205,8 +206,9 @@ (when splash (not-to-be splash) (gtk-window-set-auto-startup-notification t)) - - (setf (visible app) t) + + (with-integrity (:change :make-app-visible) + (setf (visible app) t)) (not-to-be (make-instance 'window :visible nil)) ; ph: kick gtk ... ugly app)) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp 2008/04/16 14:41:28 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp 2008/04/20 13:05:02 1.3 @@ -363,7 +363,7 @@ (when old-value (loop for col in old-value do (gtk-tree-view-remove-column (id self) (id col)) - (gtk-object-forget (id col) col))) + #+not-necessary (gtk-object-forget (id col) col))) ; ph 042008 (when new-value (loop for col in new-value for pos from 0 --- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/16 14:41:28 1.3 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/20 13:05:02 1.4 @@ -57,34 +57,33 @@ (defun gtk-objects-init () (setf *gtk-objects* (make-hash-table :size 100 :rehash-size 100) - *widgets* (make-hash-table :test #'equal))) + *widgets* (make-instance 'cells-store))) ;;; id lookup (defun gtk-object-store (gtk-id gtk-object &aux (hash-id (cffi:pointer-address gtk-id))) (unless *gtk-objects* (gtk-objects-init)) - (setf (gethash (md-name gtk-object) *widgets*) gtk-object) + (bwhen (name (md-name gtk-object)) + (store-add name *widgets* gtk-object)) (let ((known (gethash hash-id *gtk-objects*))) (cond ((eql known gtk-object)) (t - (when known + #+ssh (when known (warn (format nil "Object ~a has been reclaimed by GTK. Cells-gtk might have stale references" known))) (setf (gethash hash-id *gtk-objects*) gtk-object))))) (defun gtk-object-forget (gtk-id gtk-object) (when (and gtk-id gtk-object) - (trc nil " forgetting id/obj" gtk-id gtk-object) + (trc " forgetting id/obj" gtk-id gtk-object) (let ((ptr (cffi:pointer-address gtk-id))) - (assert *widgets*) - (when (eql (gethash (md-name gtk-object) *widgets*) gtk-object) - (remhash (md-name gtk-object) *widgets*)) (assert *gtk-objects*) (remhash ptr *gtk-objects*) - (mapc (lambda (k) (gtk-object-forget (slot-value k 'id) k)) - (slot-value gtk-object '.kids))))) + #+unnecessary (mapc (lambda (k) (gtk-object-forget (slot-value k 'id) k)) + (slot-value gtk-object '.kids))) ; unnecessary, ph + (trc " done" gtk-id gtk-object))) (defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (cffi:pointer-address gtk-id))) (when *gtk-objects* @@ -99,15 +98,13 @@ ;;; name lookup -(defun find-widget (name &optional default) - (gethash name *widgets* default)) - (defmacro with-widget ((widget name &optional alternative) &body body) - `(bif (,widget (find-widget ,name)) - (progn - (trc "with widget" ,widget ',body) - ,@body) - ,alternative)) + `(bwhen-c-stored (,widget ,name *widgets* ,alternative) + ,@body)) + +(defun find-widget (name &optional default) + (with-widget (w name default) + w)) (defmacro with-widget-value ((val name &key (accessor '(quote value)) (alternative nil)) &body body) (with-gensyms (widget) @@ -382,14 +379,24 @@ (gtk-widget-show (id self)) (gtk-widget-hide (id self)))) -(defmethod not-to-be :after ((self widget)) +(defmethod not-to-be :around ((self gtk-object)) + (trc "gtk-object not-to-be :around" (md-name self) self) + (trc " store-remove") + (when (eql (store-lookup (md-name self) *widgets*) self) + (store-remove (md-name self) *widgets*)) + (trc " object-forget") + (gtk-object-forget (id self) self) + + (trc " call-next-method") + (call-next-method) + + (trc " widget-destroy") (when *gtk-debug* - (trc "WIDGET DESTROY" (md-name self) (type-of self) self) + (trc "WIDGET DESTROY" (slot-value self '.md-name) (type-of self) self) (force-output)) - (gtk-object-forget (slot-value self 'id) self) - (trc nil "not-to-be destroys" self (slot-value self 'id)) (gtk-widget-destroy (slot-value self 'id)) - (trc nil " done")) + (trc " done")) + (defun assert-bin (container) (assert (null (rest (kids container)))

1 0

[cells-cvs] CVS cells
by phildebrandt 20 Apr '08

20 Apr '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv29075 Modified Files: md-slot-value.lisp md-utilities.lisp Log Message: Newer version of the cells-store --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/13 15:25:00 1.44 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/04/20 13:04:40 1.45 @@ -24,7 +24,7 @@ (when (and (not *not-to-be*) (mdead self)) (trc "md-slot-value passed dead self, returning NIL" self slot-name c) - (inspect self) + #-sbcl (inspect self) (break "see inspector for dead ~a" self) (return-from md-slot-value nil)) (tagbody --- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/17 15:50:37 1.18 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/20 13:04:40 1.19 @@ -91,68 +91,109 @@ ;;; cells store stuff ;;; (w) Peter Hildebrandt -(export! cells-store bwhen-gethash c?-with-stored with-store-item store-add store-lookup store-remove) +(export! cells-store bwhen-c-stored c?-with-stored with-store-item store-add store-lookup store-remove) (defmacro c?-with-stored ((var key store &optional default) &body body) - `(c? (bwhen-gethash (,var ,key ,store ,default) + `(c? (bwhen-c-stored (,var ,key ,store ,default) ,@body))) (defmacro with-uniqs ((&rest symbols) &body body) `(let ,(mapcar #'(lambda (sym) `(,sym (gensym ,(string sym)))) symbols) ,@body)) -(defmacro bwhen-gethash ((var key store &optional if-not) &body body) - (with-uniqs (gkey gstore gupdate gifnot) +(defmacro bwhen-c-stored ((var key store &optional if-not) &body body) + (with-uniqs (gkey gstore glink gifnot) `(let ((,gkey ,key) (,gstore ,store) (,gifnot ,if-not)) - (let ((,gupdate (value (get-listener ,gkey ,gstore)))) - (declare (ignorable ,gupdate)) - (trc nil "executing bwhen-gethash" self :update-tick ,gupdate :lookup (store-lookup ,gkey ,gstore)) + (let ((,glink (query-c-link ,gkey ,gstore))) + (declare (ignorable ,glink)) + (trc nil "executing bwhen-c-stored" self :update-tick ,glink :lookup (store-lookup ,gkey ,gstore)) (bif (,var (store-lookup ,gkey ,gstore)) (progn ,@body) ,gifnot))))) (defmodel cells-store (family) - ((data :accessor data :initarg :data :cell nil) - (listeners :accessor listeners :initarg :listeners :cell nil)) + ((data :accessor data :initarg :data :cell nil)) (:default-initargs - :data (make-hash-table) - :listeners (make-hash-table) - :kids (c-in nil))) + :data (make-hash-table))) ;;; infrastructure for manipulating the store and kicking rules -(defmethod get-listener (key (store cells-store)) - (or (gethash key (listeners store)) - (let ((new-listener (make-instance 'family :fm-parent store :value (c-in 0)))) - (with-integrity (:change) - (push new-listener (kids store)) - (setf (gethash key (listeners store)) new-listener)) - new-listener))) - -(defmethod kick-listener (key (store cells-store)) - (bwhen (listener (gethash key (listeners store))) - (incf (value listener)))) +(defmethod entry (key (store cells-store)) + (gethash key (data store))) -(defmacro with-store-item ((key store) &body body) +(defmethod (setf entry) (new-data key (store cells-store)) + (setf (gethash key (data store)) new-data)) + +(defmethod c-link (key (store cells-store)) + (car (entry key store))) + +(defmethod (setf c-link) (new-c-link key (store cells-store)) + (if (consp (entry key store)) + (setf (car (entry key store)) new-c-link) + (setf (entry key store) (cons new-c-link nil))) + new-c-link) + +(defmethod item (key (store cells-store)) + (cdr (entry key store))) + +(defmethod (setf item) (new-item key (store cells-store)) + (if (consp (entry key store)) + (setf (cdr (entry key store)) new-item) + (setf (entry key store) (cons nil new-item))) + new-item) + +;;; c-links + +(defmodel c-link () + ((value :accessor value :initform (c-in 0) :initarg :value))) + +(defmethod query-c-link (key (store cells-store)) + (trc "c-link> query link" key store (c-link key store)) + (value (or (c-link key store) + (setf (c-link key store) (make-instance 'c-link))))) + +(defmethod kick-c-link (key (store cells-store)) + (bwhen (link (c-link key store)) + (trc "c-link> kick link" key store link) + (with-integrity (:change :kick-c-link) + (incf (value link))))) + +(defmacro with-store-item ((item key store) &body body) `(prog1 - (progn ,@body) - (kick-listener ,key ,store))) + (symbol-macrolet ((,item '(item key store))) + (progn + ,@body)) + (kick-c-link ,key ,store))) + + +(defmacro with-store-entry ((key store &key quiet) &body body) + `(prog1 + (progn + ,@body) + (unless ,quiet + (kick-c-link ,key ,store)))) ;;; item management -(defmethod store-add (key (store cells-store) object) - (with-store-item (key store) - (setf (gethash key (data store)) object))) +(defmethod store-add (key (store cells-store) object &key quiet) + (with-store-entry (key store :quiet quiet) + (when (item key store) + (trc "overwriting item" key (item key store))) + (setf (item key store) object))) (defmethod store-lookup (key (store cells-store) &optional default) - (gethash key (data store) default)) - -(defmethod store-remove (key (store cells-store)) - (with-store-item (key store) - (remhash key (data store)))) + (when (mdead (item key store)) + (with-store-entry (key store) + (trc "looked up dead item -- resetting to nil" key store) + (setf (item key store) nil))) + (or (item key store) default)) + +(defmethod store-remove (key (store cells-store) &key quiet) + (with-store-entry (key store :quiet quiet) + (setf (item key store) nil))) ;;; unit test @@ -199,7 +240,7 @@ (bypass-lookup? (make-instance 'family :value (c-in t))) (baz (make-instance 'test-store-item :value (c? (if (value bypass-lookup?) 'no-lookup - (bwhen-gethash (v :bar store 'nothing) + (bwhen-c-stored (v :bar store 'nothing) (value v))))))) (assert-values ("assert fresh initialization")

1 0

[cells-cvs] CVS Celtk
by fgoenninger 17 Apr '08

17 Apr '08

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv8038 Added Files: tk-file.lisp Log Message: First Check-In. --- /project/cells/cvsroot/Celtk/tk-file.lisp 2008/04/17 16:16:44 NONE +++ /project/cells/cvsroot/Celtk/tk-file.lisp 2008/04/17 16:16:44 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- #| Celtk -- Cells, Tcl, and Tk Copyright (C) 2006, 2007 by Kenneth Tilton This file: Copyright (C) 2007 by Frank Goenninger This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :Celtk) (defun do-tk-get-open-file (self args) (tk-open-file self args)) (defmacro tk-get-open-file (self args) `(tk-format-now "Tk_getOpenFile"))

1 0

[cells-cvs] CVS Celtk
by fgoenninger 17 Apr '08

17 Apr '08

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv7782 Modified Files: fileevent.lisp Log Message: Changed: handle tile? for fileevent. --- /project/cells/cvsroot/Celtk/fileevent.lisp 2006/11/04 20:53:08 1.9 +++ /project/cells/cvsroot/Celtk/fileevent.lisp 2008/04/17 16:13:05 1.10 @@ -21,7 +21,7 @@ ;;; DEALINGS IN THE SOFTWARE. ;;; ;;; --------------------------------------------------------------------------- -;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.9 2006/11/04 20:53:08 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/fileevent.lisp,v 1.10 2008/04/17 16:13:05 fgoenninger Exp $ ;;; --------------------------------------------------------------------------- ;;; =========================================================================== @@ -44,8 +44,7 @@ ;;; TK-FILEEVENT MODEL ;;; =========================================================================== -(defmodel tk-fileevent (widget) - +(defmodel tk-fileevent (window) ((.md-name :accessor id :initarg :id :initform (c-in nil) @@ -145,8 +144,8 @@ (:default-initargs :id (gensym "tk-fileevent-") - :eof-fn 'default-eof-fn)) - + :eof-fn 'default-eof-fn + :tile? nil)) ;;; =========================================================================== ;;; CELL RULE: FILE-EVENT/OPCODE @@ -564,7 +563,7 @@ (mk-fileevent :id :fileevent-test :read-fn 'USRF :iostream (c-in - (open "/Users/frgo/dribble.lisp" + (open "/dev/cu.usbserial" ;;; Adapt here !!! ^^^^^^^^^^^^^^^^^^^^^^^^^^^ :direction :input))))))) @@ -574,5 +573,4 @@ (test-window 'fileevent-test-window) (trc "-----------------------------------------------------------------------------")) -#+test -(test-window 'fileevent-test-window) \ No newline at end of file +#+test (test-window 'fileevent-test-window) \ No newline at end of file

1 0

[cells-cvs] CVS Celtk
by fgoenninger 17 Apr '08

17 Apr '08

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv7688 Modified Files: Celtk.asd Log Message: Changed: Updated .asd file to reflect .lpr file. --- /project/cells/cvsroot/Celtk/Celtk.asd 2007/01/29 23:06:35 1.12 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2008/04/17 16:11:48 1.13 @@ -38,6 +38,5 @@ (:file "fileevent") (:file "togl") (:file "run") - (:file "ltktest-ci") - (:file "lotsa-widgets") - (:file "demos"))) + (:file "movie") + (:file "tk-file")))

1 0

[cells-cvs] CVS cells
by phildebrandt 17 Apr '08

17 Apr '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv32577 Modified Files: md-utilities.lisp Log Message: added bwhen-gethash --- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/17 13:52:57 1.17 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/17 15:50:37 1.18 @@ -91,16 +91,28 @@ ;;; cells store stuff ;;; (w) Peter Hildebrandt -(export! cells-store c?-with-stored with-store-item store-add store-lookup store-remove) +(export! cells-store bwhen-gethash c?-with-stored with-store-item store-add store-lookup store-remove) (defmacro c?-with-stored ((var key store &optional default) &body body) - `(c? (let ((something (value (get-listener ,key ,store)))) - (declare (ignorable something)) - (trc nil "executing c?-bwhen" self :something something :lookup (store-lookup ,key ,store)) - (bif (,var (store-lookup ,key ,store)) - (progn - ,@body) - ,default)))) + `(c? (bwhen-gethash (,var ,key ,store ,default) + ,@body))) + +(defmacro with-uniqs ((&rest symbols) &body body) + `(let ,(mapcar #'(lambda (sym) `(,sym (gensym ,(string sym)))) symbols) + ,@body)) + +(defmacro bwhen-gethash ((var key store &optional if-not) &body body) + (with-uniqs (gkey gstore gupdate gifnot) + `(let ((,gkey ,key) + (,gstore ,store) + (,gifnot ,if-not)) + (let ((,gupdate (value (get-listener ,gkey ,gstore)))) + (declare (ignorable ,gupdate)) + (trc nil "executing bwhen-gethash" self :update-tick ,gupdate :lookup (store-lookup ,gkey ,gstore)) + (bif (,var (store-lookup ,gkey ,gstore)) + (progn + ,@body) + ,gifnot))))) (defmodel cells-store (family) ((data :accessor data :initarg :data :cell nil) @@ -183,7 +195,12 @@ (bar (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing) (bwhen (val (value v)) val)))) (bar-1 (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing) - (bwhen (val (value v)) (1- val)))))) + (bwhen (val (value v)) (1- val))))) + (bypass-lookup? (make-instance 'family :value (c-in t))) + (baz (make-instance 'test-store-item :value (c? (if (value bypass-lookup?) + 'no-lookup + (bwhen-gethash (v :bar store 'nothing) + (value v))))))) (assert-values ("assert fresh initialization") (foo 'nothing) @@ -227,6 +244,15 @@ (bar 2) (bar-1 1)) + (assert-values ("baz w/o lookup") + (baz 'no-lookup)) + + (with-assert-observers ("activating lookup" baz) + (setf (value bypass-lookup?) nil)) + + (assert-values ("baz w/lookup") + (baz 2)) + (with-assert-observers ("deleting foo" foo foo+1) (store-remove :foo store)) @@ -236,11 +262,18 @@ (bar 2) (bar-1 1)) - (with-assert-observers ("deleting bar" bar bar-1) + (with-assert-observers ("deleting bar" bar bar-1 baz) (store-remove :bar store)) (assert-values ("deleted bar") (foo 'nothing) (foo+1 'nothing) (bar 'nothing) - (bar-1 'nothing)))) \ No newline at end of file + (bar-1 'nothing) + (baz 'nothing)) + + (with-assert-observers ("de-activating lookup" baz) + (setf (value bypass-lookup?) t)) + + (assert-values ("baz w/o lookup") + (baz 'no-lookup)))) \ No newline at end of file

1 0

[cells-cvs] CVS cells
by phildebrandt 17 Apr '08

17 Apr '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv5160 Modified Files: md-utilities.lisp Log Message: v1.1 --- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/17 13:39:00 1.16 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/17 13:52:57 1.17 @@ -138,7 +138,7 @@ (defmethod store-lookup (key (store cells-store) &optional default) (gethash key (data store) default)) -(defmethod store-remove (key (store cells-hash-store)) +(defmethod store-remove (key (store cells-store)) (with-store-item (key store) (remhash key (data store)))) @@ -225,4 +225,22 @@ (foo 1) (foo+1 2) (bar 2) - (bar-1 1)))) \ No newline at end of file + (bar-1 1)) + + (with-assert-observers ("deleting foo" foo foo+1) + (store-remove :foo store)) + + (assert-values ("deleted foo") + (foo 'nothing) + (foo+1 'nothing) + (bar 2) + (bar-1 1)) + + (with-assert-observers ("deleting bar" bar bar-1) + (store-remove :bar store)) + + (assert-values ("deleted bar") + (foo 'nothing) + (foo+1 'nothing) + (bar 'nothing) + (bar-1 'nothing)))) \ No newline at end of file

1 0

[cells-cvs] CVS cells
by phildebrandt 17 Apr '08

17 Apr '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv1592 Modified Files: md-utilities.lisp Log Message: Added a cells-store. --- /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/12 22:53:26 1.15 +++ /project/cells/cvsroot/cells/md-utilities.lisp 2008/04/17 13:39:00 1.16 @@ -86,3 +86,143 @@ ,@initargs :fm-parent (progn (assert self) self))) + +;;; +;;; cells store stuff +;;; (w) Peter Hildebrandt + +(export! cells-store c?-with-stored with-store-item store-add store-lookup store-remove) + +(defmacro c?-with-stored ((var key store &optional default) &body body) + `(c? (let ((something (value (get-listener ,key ,store)))) + (declare (ignorable something)) + (trc nil "executing c?-bwhen" self :something something :lookup (store-lookup ,key ,store)) + (bif (,var (store-lookup ,key ,store)) + (progn + ,@body) + ,default)))) + +(defmodel cells-store (family) + ((data :accessor data :initarg :data :cell nil) + (listeners :accessor listeners :initarg :listeners :cell nil)) + (:default-initargs + :data (make-hash-table) + :listeners (make-hash-table) + :kids (c-in nil))) + +;;; infrastructure for manipulating the store and kicking rules + +(defmethod get-listener (key (store cells-store)) + (or (gethash key (listeners store)) + (let ((new-listener (make-instance 'family :fm-parent store :value (c-in 0)))) + (with-integrity (:change) + (push new-listener (kids store)) + (setf (gethash key (listeners store)) new-listener)) + new-listener))) + +(defmethod kick-listener (key (store cells-store)) + (bwhen (listener (gethash key (listeners store))) + (incf (value listener)))) + +(defmacro with-store-item ((key store) &body body) + `(prog1 + (progn ,@body) + (kick-listener ,key ,store))) + +;;; item management + +(defmethod store-add (key (store cells-store) object) + (with-store-item (key store) + (setf (gethash key (data store)) object))) + +(defmethod store-lookup (key (store cells-store) &optional default) + (gethash key (data store) default)) + +(defmethod store-remove (key (store cells-hash-store)) + (with-store-item (key store) + (remhash key (data store)))) + + +;;; unit test + +(export! test-cells-store) + +(defmodel test-store-item (family) + ()) + +(defvar *observers*) + +(defobserver .value ((self test-store-item)) + (trc " changed value" :self self :to (value self)) + (when (boundp '*observers*) + (push self *observers*))) + +(defmacro with-assert-observers ((desc &rest asserted-observers) &body body) + `(let ((*observers* nil)) + (trc ,desc " -- checking observers") + ,@body + (let ((superflous-observers (loop for run in *observers* if (not (member run (list ,@asserted-observers))) collect run)) + (failed-observers (loop for asserted in (list ,@asserted-observers) if (not (member asserted *observers*)) collect asserted))) + (trc "called observers on" *observers* :superflous superflous-observers :failed failed-observers) + (assert (not superflous-observers)) + (assert (not failed-observers))))) + +(defmacro assert-values ((desc) &body objects-and-values) + `(progn + (trc ,desc) + ,@(loop for (obj val) in objects-and-values + collect `(assert (eql (value ,obj) ,val))))) + +(defun test-cells-store () + (trc "testing cells-store -- making objects") + (let* ((store (make-instance 'cells-store)) + (foo (make-instance 'test-store-item :value (c?-with-stored (v :foo store 'nothing) + (bwhen (val (value v)) val)))) + (foo+1 (make-instance 'test-store-item :value (c?-with-stored (v :foo store 'nothing) + (bwhen (val (value v)) (1+ val))))) + (bar (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing) + (bwhen (val (value v)) val)))) + (bar-1 (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing) + (bwhen (val (value v)) (1- val)))))) + + (assert-values ("assert fresh initialization") + (foo 'nothing) + (foo+1 'nothing) + (bar 'nothing) + (bar-1 'nothing)) + + (with-assert-observers ("adding foo" foo foo+1) + (store-add :foo store (make-instance 'family :value (c-in nil)))) + + (assert-values ("added foo = nil") + (foo nil) + (foo+1 nil) + (bar 'nothing) + (bar-1 'nothing)) + + (with-assert-observers ("changing foo" foo foo+1) + (setf (value (store-lookup :foo store)) 1)) + + (assert-values ("changed foo = 1") + (foo 1) + (foo+1 2) + (bar 'nothing) + (bar-1 'nothing)) + + (with-assert-observers ("adding bar = 42" bar bar-1) + (store-add :bar store (make-instance 'family :value (c-in 42)))) + + (assert-values ("changed foo = 1") + (foo 1) + (foo+1 2) + (bar 42) + (bar-1 41)) + + (with-assert-observers ("changing bar to 2" bar bar-1) + (setf (value (store-lookup :bar store)) 2)) + + (assert-values ("changed foo = 1") + (foo 1) + (foo+1 2) + (bar 2) + (bar-1 1)))) \ No newline at end of file

1 0

← Newer
1
2
3
4
5
6
7
8
9
...
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