Commit 8e725cc5 authored by Kenny Tilton's avatar Kenny Tilton
Browse files

nothing special

parent 0ee74716
......@@ -13,8 +13,8 @@ For example, in a text editor application we might have (condensed):
(make-instance 'menu-item
:label "Cut"
:enabled (c? (bwhen (f (focus *window*))
(and (typep focus 'text-widget)
(selection-range focus)))))
(and (typep f 'text-widget)
(selection-range f)))))
Translated, the enabled state of the Cut menu item follows
whether or not the user is focused on a text-edit widget and
......@@ -102,7 +102,9 @@ 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 developing axiomatic
definition he is developing in support of Ryan Forseth's SoC project.
definition he is developing in support of Ryan Forseth's SoC project. Mr. Eby was
inspired by his involvement to develop Trellis, his own Cells work-alike library
for Python.
DEFMODEL and Slot types
-----------------------
......@@ -351,6 +353,9 @@ PhD Thesis in which he develops a constraint programming language or two:
http://portal.acm.org/citation.cfm?id=889490&dl=ACM&coll=ACM
http://www.cs.utk.edu/~bvz/quickplan.html
Flow-based programming, developed by J. Paul Morrison at IBM, 1971.
http://en.wikipedia.org/wiki/Flow-based_programming
Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963.
Steele himself cites Sketchpad as inexplicably unappreciated prior
art to his Constraints system:
......
......@@ -150,30 +150,31 @@ a cellular slot (or in a list in such) and then mop those up on not-to-be.
(break "~&i say, unhandled <c-enabling>: ~s" condition))))
(define-condition c-fatal (xcell)
((name :initarg :name :reader name)
(model :initarg :model :reader model)
(cell :initarg :cell :reader cell))
((name :initform :anon :initarg :name :reader name)
(model :initform nil :initarg :model :reader model)
(cell :initform nil :initarg :cell :reader cell))
(:report (lambda (condition stream)
(format stream "~&fatal cell programming error: ~s" condition)
(format stream "~& : ~s" (name condition))
(format stream "~& : ~s" (model condition))
(format stream "~& : ~s" (cell condition)))))
(define-condition c-unadopted (c-fatal)
()
(define-condition asker-midst-askers (c-fatal)
())
;; "see listener for cell rule cycle diagnotics"
(define-condition c-unadopted (c-fatal) ()
(:report
(lambda (condition stream)
(format stream "~&unadopted cell >: ~s" (cell condition))
(format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error"))))
(defun c-break (&rest args)
(unless *stop*
(let ((*print-level* 5)
(*print-circle* t)
(args2 (mapcar 'princ-to-string args)))
(c-stop args)
(format t "~&c-break > stopping > ~{~a ~}" args2)
(print `(c-break-args ,@args2))
(c-stop :c-break)
;(format t "~&c-break > stopping > ~{~a ~}" args2)
(apply 'error args2))))
\ No newline at end of file
......@@ -185,6 +185,8 @@ the defmodel form for ~a" ',class ',class))))
(list* `(:default-initargs ,@definitargs)
(nreverse class-options)))))))))
#+test
(progn
(defclass md-test-super ()())
......
......@@ -26,9 +26,13 @@ See the Lisp Lesser GNU Public License for more details.
((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name)
(.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent)
(.value :initform nil :accessor value :initarg :value)
(register? :cell nil :initform nil :initarg :register? :reader register?)
(zdbg :initform nil :accessor dbg :initarg :dbg))
)
(defmethod initialize-instance :after ((self model) &key)
(when (register? self)
(fm-register self)))
(defmethod print-cell-object ((md model))
(or (md-name md) :md?))
......@@ -92,7 +96,14 @@ See the Lisp Lesser GNU Public License for more details.
(.kids :initform (c-in nil) ;; most useful
:owning t
:accessor kids
:initarg :kids)))
:initarg :kids)
(registry? :cell nil
:initform nil
:initarg :registry?
:accessor registry?)
(registry :cell nil
:initform nil
:accessor registry)))
#+test
(let ((c (find-class 'family)))
......@@ -143,14 +154,11 @@ See the Lisp Lesser GNU Public License for more details.
`(let ((,kid ,self))
(find-prior ,kid (kids (fm-parent ,kid))))))
(defun md-be-adopted (self &aux (fm-parent (fm-parent self)) (selftype (type-of self)))
(defun md-be-adopted (self &aux (fm-parent (fm-parent self)) (selftype (type-of self)))
(c-assert self)
(c-assert fm-parent)
(c-assert (typep fm-parent 'family))
(trc nil "md be adopted >" :kid self (adopt-ct self) :by fm-parent)
(when (plusp (adopt-ct self))
......@@ -209,5 +217,45 @@ See the Lisp Lesser GNU Public License for more details.
(declare (ignorable self))
(list ,@slot-defs)))
; --- registry "namespacing" ---
(defmethod registry? (other) (declare (ignore other)) nil)
(defmethod initialize-instance :after ((self family) &key)
(when (registry? self)
(setf (registry self) (make-hash-table :test 'eq))))
(defmethod fm-register (self &optional (guest self))
(assert self)
(if (registry? self)
(progn
(trc "fm-registering" (md-name guest) :with self)
(setf (gethash (md-name guest) (registry self)) guest))
(fm-register (fm-parent self) guest)))
(defmethod fm-check-out (self &optional (guest self))
(assert self () "oops ~a ~a ~a" self (fm-parent self) (slot-value self '.fm-parent))
(if (registry? self)
(remhash (md-name guest) (registry self))
(bif (p (fm-parent self))
(fm-check-out p guest)
(break "oops ~a ~a ~a" self (fm-parent self) (slot-value self '.fm-parent)))))
(defmethod fm-find-registered (id self &optional (must-find? self must-find?-supplied?))
(or (if (registry? self)
(gethash id (registry self))
(bwhen (p (fm-parent self))
(fm-find-registered id p must-find?)))
(when (and must-find? (not must-find?-supplied?))
(break "fm-find-registered failed seeking ~a starting search at node ~a" id self))))
(export! rg? rg!)
(defmacro rg? (id)
`(fm-find-registered ,id self nil))
(defmacro rg! (id)
`(fm-find-registered ,id self))
\ No newline at end of file
......@@ -14,7 +14,7 @@ the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
$Header$
$Header: /project/cells/cvsroot/cells/fm-utilities.lisp,v 1.20 2008/05/24 19:24:05 fgoenninger Exp $
|#
(in-package :cells)
......@@ -702,7 +702,6 @@ $Header$
:global-search global-search))))
(when (and must-find (null match))
(trc "fm-find-one > erroring fm-not-found, in family: " family :seeking md-name :global? global-search)
;;(inspect family)
(setq diag t must-find nil)
(fm-traverse family #'matcher
:skip-tree skip-tree
......
......@@ -102,6 +102,7 @@ See the Lisp Lesser GNU Public License for more details.
(^prior-sib-pr self (spacing .parent)))))))))))
(defun ^prior-sib-pb (self &optional (spacing 0)) ;; just keeping with -pt variant till both converted to defun
(bif (psib (find-prior self (kids .parent)
:test (lambda (sib)
......@@ -118,23 +119,35 @@ See the Lisp Lesser GNU Public License for more details.
(c? (py-maintain-pt (round (- (l-height .parent) (l-height self)) -2))))
;--------------- geo.row.flow ----------------------------
(export! geo-row-flow)
(export! geo-row-flow fixed-col-width ^fixed-col-width ^spacing-hz spacing-hz
max-per-row ^max-per-row)
(defmd geo-row-flow (geo-inline)
(spacing-hz 0)
(spacing-vt 0)
(aligned :cell nil)
fixed-col-width
max-per-row
(row-flow-layout
(c? (loop with max-pb = 0 and pl = 0 and pt = 0
for k in (^kids)
for kpr = (+ pl (l-width k))
for kn upfrom 0
for kw = (or (^fixed-col-width) (l-width k))
for kpr = (+ pl kw)
when (unless (= pl 0)
(> kpr (- (l-width self) (outset self)))) do
(if (^max-per-row)
(zerop (mod kn (^max-per-row)))
(> kpr (- (l-width self) (outset self)))))
do
(when (> kpr (- (l-width self) (outset self)))
(trc nil "LR overflow break" kpr :gt (- (l-width self) (outset self))))
(when (zerop (mod kn (^max-per-row)))
(trc nil "max/row break" kn (^max-per-row) (mod kn (^max-per-row))))
(setf pl 0
pt (+ max-pb (downs (^spacing-vt))))
collect (cons pl pt) into pxys
do (incf pl (+ (l-width k)(^spacing-hz)))
do (incf pl (+ kw (^spacing-hz)))
(setf max-pb (min max-pb (+ pt (downs (l-height k)))))
finally (return (cons max-pb pxys)))))
:lb (c? (+ (bif (xys (^row-flow-layout))
......
......@@ -66,6 +66,7 @@ See the Lisp Lesser GNU Public License for more details.
*unfinished-business*
*defer-changes*)
(trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info)
(when *c-debug* (assert (boundp '*istack*)))
(when (or (zerop *data-pulse-id*)
(eq opcode :change))
(eko (nil "!!! New pulse, event" *data-pulse-id* defer-info)
......@@ -77,15 +78,17 @@ See the Lisp Lesser GNU Public License for more details.
(let ((*istack* (list (list opcode defer-info)
(list :trigger code)
(list :start-dp *data-pulse-id*))))
(trc "*istack* bound")
(handler-case
(go-go)
(t (c)
(xcell (c)
(if (functionp *c-debug*)
(funcall *c-debug* c (nreverse *istack*))
(loop for f in (nreverse *istack*)
do (format t "~&istk> ~(~a~) " f)
finally (describe c)
(break "integ backtrace: see listener for deets"))))))
(break "integ backtrace: see listener for deets")))))
(trc "*istack* unbinding"))
(go-go)))))
(defun ufb-queue (opcode)
......@@ -163,7 +166,7 @@ See the Lisp Lesser GNU Public License for more details.
; dependent reverses the arrow and puts the burden on the prosecution to prove nested tells are a problem.
(bwhen (uqp (fifo-peek (ufb-queue :tell-dependents)))
#+x42 (trc "retelling dependenst, one new one being" uqp)
#+xxx (trc "retelling dependenst, one new one being" uqp)
(go tell-dependents))
;--- process client queue ------------------------------
......
......@@ -58,8 +58,7 @@ See the Lisp Lesser GNU Public License for more details.
(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))
(declare (ignorable dbg usage-size))
(when (cd-useds c)
(let (rev-pos)
......
......@@ -23,9 +23,11 @@ See the Lisp Lesser GNU Public License for more details.
(defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name)))
(when (and (not *not-to-be*)
(mdead self))
(trc "md-slot-value passed dead self, returning NIL" self slot-name c)
#-sbcl (inspect self)
(break "see inspector for dead ~a" self)
(unless *stop*
(setf *stop* t)
(trc "md-slot-value passed dead self, returning NIL" self slot-name c)
#-sbcl (inspect self)
(break "see inspector for dead ~a" self))
(return-from md-slot-value nil))
(tagbody
retry
......@@ -47,7 +49,7 @@ See the Lisp Lesser GNU Public License for more details.
;; (count-it :md-slot-value slot-name)
(if c
(cell-read c)
(values (bd-slot-value self slot-name) nil)))
(values (slot-value self slot-name) nil)))
(defun cell-read (c)
(assert (typep c 'cell))
......@@ -61,12 +63,6 @@ See the Lisp Lesser GNU Public License for more details.
(when (mdead 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))))
(defvar *trc-ensure* nil)
(defmethod ensure-value-is-current (c debug-id ensurer)
......@@ -145,6 +141,7 @@ See the Lisp Lesser GNU Public License for more details.
nil)
v)))
(defun calculate-and-set (c)
(flet ((body ()
(when (c-stopped)
......@@ -154,19 +151,18 @@ See the Lisp Lesser GNU Public License for more details.
#-its-alive!
(bwhen (x (find c *call-stack*)) ;; circularity
(unless nil ;; *stop*
(let ((stack (copy-list *call-stack*)))
(trc "calculating cell ~a appears in call stack: ~a" c x stack )))
(setf *stop* t)
(c-break "yep" c)
(loop with caller-reiterated
for caller in *call-stack*
until caller-reiterated
do (trc "caller:" caller)
;; not necessary (pprint (cr-code c))
(setf caller-reiterated (eq caller c)))
(let ()
(inspect c)
(trc "calculating cell:" c (cr-code c))
(trc "appears-in-call-stack (newest first): " (length *call-stack*))
(loop for caller in (copy-list *call-stack*)
for n below (length *call-stack*)
do (trc "caller> " caller #+shhh (cr-code caller))
when (eq caller c) do (loop-finish))))
(setf *stop* t)
(c-break ;; break is problem when testing cells on some CLs
"cell ~a midst askers (see above)" c)
(error "see listener for cell rule cycle diagnotics"))
(error 'asker-midst-askers :cell c))
(multiple-value-bind (raw-value propagation-code)
(calculate-and-link c)
......@@ -197,6 +193,20 @@ See the Lisp Lesser GNU Public License for more details.
(funcall (cr-rule c) c)
(c-unlink-unused c))))
#+theabove!
(defun calculate-and-set (c)
(multiple-value-bind (raw-value propagation-code)
(let ((*call-stack* (cons c *call-stack*))
(*depender* c)
(*defer-changes* t))
(cd-usage-clear-all c)
(multiple-value-prog1
(funcall (cr-rule c) c)
(c-unlink-unused c)))
(unless (c-optimized-away-p c)
(md-slot-value-assume c raw-value propagation-code))))
;-------------------------------------------------------------
(defun md-slot-makunbound (self slot-name
......
......@@ -54,7 +54,7 @@ See the Lisp Lesser GNU Public License for more details.
(:method ((self model-object))
(md-quiesce self))
(:method :before ((self model-object))
(loop for slot-name in (md-owning-slots self)
do (not-to-be (slot-value self slot-name))))
......@@ -62,8 +62,7 @@ See the Lisp Lesser GNU Public License for more details.
(:method :around ((self model-object))
(declare (ignorable 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)))))
(dbg nil))
(flet ((gok ()
(unless (eq (md-state self) :eternal-rest)
......@@ -85,13 +84,15 @@ See the Lisp Lesser GNU Public License for more details.
(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)
(trc nil "quiescing" c)
(c-assert (not (find c *call-stack*)))
(c-quiesce c))))
(c-quiesce c)))
(when (register? self)
(fm-check-out self)))
(defun c-quiesce (c)
(typecase c
......@@ -112,3 +113,78 @@ See the Lisp Lesser GNU Public License for more details.
,@initargs
:fm-parent (progn (assert self) self)))
(export! self-owned self-owned?)
(defun (setf self-owned) (new-value self thing)
(if (consp thing)
(loop for e in thing do
(setf (self-owned self e) new-value))
(if new-value
(progn
(assert (not (find thing (z-owned self))))
(push thing (z-owned self)))
(progn
(assert (find thing (z-owned self)))
(setf (z-owned self)(delete thing (z-owned self)))))))
(defun self-owned? (self thing)
(find thing (z-owned self)))
(defvar *c-d-d*)
(defvar *max-d-d*)
(defun count-model (self)
(setf *c-d-d* (make-hash-table :test 'eq) *max-d-d* 0)
(with-metrics (t nil "cells statistics for" self)
(labels ((cc (self)
(count-it :thing)
(count-it :thing (type-of self))
;(count-it :thing-type (type-of self))
(loop for (id . c) in (cells self)
do (count-it :live-cell)
;(count-it :live-cell id)
(typecase c
(c-dependent
(count-it :dependent-cell)
(loop repeat (length (c-useds c))
do (count-it :cell-useds)
(count-it :dep-depth (c-depend-depth c))))
(otherwise (if (c-inputp c)
(count-it :c-input id)
(count-it :c-unknow))))
(loop repeat (length (c-callers c))
do (count-it :cell-callers)))
(loop repeat (length (cells-flushed self))
do (count-it :flushed-cell #+toomuchinfo id))
(loop for slot in (md-owning-slots self) do
(loop for k in (let ((sv (SLOT-VALUE self slot)))
(if (listp sv) sv (list sv)))
do (cc k)))))
(cc self))))
(defun c-depend-depth (ctop)
(if (null (c-useds ctop))
0
(or (gethash ctop *c-d-d*)
(labels ((cdd (c &optional (depth 1) chain)
(when (and (not (c-useds c))
(> depth *max-d-d*))
(setf *max-d-d* depth)
(trc "new dd champ from user" depth :down-to c)
(when (= depth 41)
(trc "end at" (c-slot-name c) :of (type-of (c-model c)))
(loop for c in chain do
(trc "called by" (c-slot-name c) :of (type-of (c-model c))))))
(setf (gethash c *c-d-d*)
;(break "c-depend-depth ~a" c)
(progn
;(trc "dd" c)
(1+ (loop for u in (c-useds c)
maximizing (cdd u (1+ depth) (cons c chain))))))))
(cdd ctop)))))
\ No newline at end of file
......@@ -21,15 +21,17 @@ See the Lisp Lesser GNU Public License for more details.
;;; --- model-object ----------------------
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(md-name fm-parent .parent)))
(export '(md-name fm-parent .parent z-owned)))
(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]
(.awaken-on-init-p :initform nil :initarg :awaken-on-init-p :accessor awaken-on-init-p)
(.cells :initform nil :accessor cells)
(.cells-flushed :initform nil :accessor cells-flushed
:documentation "cells supplied but un-whenned or optimized-away")
(adopt-ct :initform 0 :accessor adopt-ct)))
(adopt-ct :initform 0 :accessor adopt-ct)
(z-owned :initform nil :accessor z-owned ;; experimental, not yet operative
:documentation "Things such as kids to be taken down when self is taken down")))
(defmethod md-state ((self symbol))
:alive)
......@@ -202,7 +204,8 @@ See the Lisp Lesser GNU Public License for more details.
(dolist (super (class-precedence-list (find-class class-name))
(setf (md-slot-cell-type class-name slot-name) nil))
(bwhen (entry (assoc slot-name (get (c-class-name super) :cell-types)))
(return-from md-slot-cell-type (setf (md-slot-cell-type class-name slot-name) (cdr entry))))))))
(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)
(assert class-name)
......@@ -216,12 +219,6 @@ 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)))))))
#+hunh
(md-slot-owning? 'mathx::prb-solver '.kids)
#+hunh
(cdr (assoc '.value (get 'm-index :indirect-ownings)))
#+test
(md-slot-owning? 'm-index '.value)
......@@ -289,6 +286,10 @@ See the Lisp Lesser GNU Public License for more details.
(defun (setf md-slot-cell) (new-cell self slot-name)
(if self ;; not on def-c-variables
(bif (entry (assoc slot-name (cells self)))
; this next branch guessed it would only occur during kid-slotting,
; before any dependency-ing could have happened, but a math-editor
; is silently switching between implied-multiplication and mixed numbers
; while they type and it
(let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter
(declare (ignorable old))
(c-assert (null (c-callers old)))
......
......@@ -58,12 +58,8 @@ See the Lisp Lesser GNU Public License for more details.
(setf (c-pulse c) *data-pulse-id*))
;--------------- propagate ----------------------------
; n.b. the cell argument may have been optimized away,
; though it is still receiving final processing here.
;
(defparameter *per-cell-handler* nil)
......
......@@ -22,7 +22,7 @@
(defun tcprop ()
(untrace)
(test-prep)
(ukt:test-prep)
(LET ((box (make-instance 'tcp)))
(trc "changing top to 10" *data-pulse-id*)
(setf (top box) 10)
......
......@@ -19,13 +19,12 @@ See the Lisp Lesser GNU Public License for more details.
(in-package :cells)
;----------- trc -------------------------------------------
(defparameter *last-trc* (get-internal-real-time))
(defparameter *trcdepth* 0)
(defun trcdepth-reset ()
(setf *trcdepth* 0))
(defmacro trc (tgt-form &rest os)
(if (eql tgt-form 'nil)
'(progn)
......@@ -45,8 +44,23 @@ See the Lisp Lesser GNU Public License for more details.
(count-it :trcfailed)))
(count-it :tgtnileval)))))))
(export! brk brkx .bgo)
(defun call-trc (stream s &rest os)
;(break)
(if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*)
*trcdepth*)
(format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)
(format stream "~&"))
;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10))
(setf *last-trc* (get-internal-real-time))
(format stream "~a" s)
(let (pkwp)
(dolist (o os)
(format stream (if pkwp " ~(~s~)" " ~(~s~)") o) ;; save, used to insert divider, trcx dont like
(setf pkwp (keywordp o))))
(force-output stream)
(values))
(export! brk brkx .bgo)
(define-symbol-macro .bgo (break "go"))
......@@ -68,23 +82,8 @@ See the Lisp Lesser GNU Public License for more details.