Permalink
Browse files

*** empty log message ***

  • Loading branch information...
1 parent 1c84484 commit d2aa98552d185e58a415a66b04e228f766a476e8 ktilton committed Apr 22, 2008
Showing with 53 additions and 28 deletions.
  1. +1 −1 defmodel.lisp
  2. +3 −6 family.lisp
  3. +1 −0 gui-geometry/geometer.lisp
  4. +2 −1 md-slot-value.lisp
  5. +41 −15 md-utilities.lisp
  6. +4 −4 model-object.lisp
  7. +1 −1 propagate.lisp
View
@@ -103,7 +103,7 @@ the defmodel form for ~a" ',class ',class))))
`(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)))
View
@@ -19,7 +19,7 @@ See the Lisp Lesser GNU Public License for more details.
(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 @@ See the Lisp Lesser GNU Public License for more details.
(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 @@ See the Lisp Lesser GNU Public License for more details.
(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 ----------------------------
;
@@ -46,6 +46,7 @@ See the Lisp Lesser GNU Public License for more details.
(mk-kid-slot (py :if-missing t)
(c? (py-maintain-pt 0))))))
+(export! geo-kid-sized)
(defmodel geo-kid-sized (family)
()
(:default-initargs
View
@@ -69,12 +69,13 @@ See the Lisp Lesser GNU Public License for more details.
(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)
View
@@ -40,26 +40,52 @@ See the Lisp Lesser GNU Public License for more details.
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)
View
@@ -216,17 +216,17 @@ See the Lisp Lesser GNU Public License for more details.
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)
(bif (entry (assoc slot-name (get class-name :ownings)))
(cdr entry)
(dolist (super (class-precedence-list (find-class class-name)))
(bwhen (entry (assoc slot-name (get (c-class-name super) :ownings)))
- (return (setf (md-slot-owning class-name slot-name) (cdr entry))))))))
+ (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 @@ See the Lisp Lesser GNU Public License for more details.
(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)
View
@@ -105,7 +105,7 @@ See the Lisp Lesser GNU Public License for more details.
;
(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))))

0 comments on commit d2aa985

Please sign in to comment.