Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

*** empty log message ***

  • Loading branch information...
commit 7a387a10a4a180f73bfe8b5b4837fb9a04e2595a 1 parent 3b95fb7
ktilton authored
Showing with 497 additions and 356 deletions.
  1. +1 −1  cell-types.lisp
  2. +14 −7 cells-manifesto.txt
  3. +62 −54 cells-test/cells-test.lpr
  4. +5 −5 cells-test/deep-cells.lisp
  5. +23 −0 cells-test/test-synapse.lisp
  6. +2 −0  cells-test/test.lisp
  7. +12 −0 cells.lisp
  8. +2 −2 cells.lpr
  9. +8 −1 constructors.lisp
  10. +3 −1 defmodel.lisp
  11. +1 −1  defpackage.lisp
  12. +0 −1  family.lisp
  13. +45 −9 fm-utilities.lisp
  14. +1 −1  gui-geometry/geo-data-structures.lisp
  15. +44 −23 gui-geometry/geo-family.lisp
  16. +3 −132 gui-geometry/geometer.lisp
  17. +2 −1  gui-geometry/gui-geometry.lpr
  18. +26 −12 integrity.lisp
  19. +2 −1  link.lisp
  20. +30 −12 md-slot-value.lisp
  21. +12 −14 md-utilities.lisp
  22. +5 −5 model-object.lisp
  23. +17 −13 propagate.lisp
  24. +12 −0 synapse-types.lisp
  25. +1 −2  synapse.lisp
  26. +1 −0  test-synapse.lisp
  27. +22 −14 trc-eko.lisp
  28. +75 −0 utils-kt/core.lisp
  29. +3 −0  utils-kt/datetime.lisp
  30. +19 −0 utils-kt/debug.lisp
  31. +3 −23 utils-kt/defpackage.lisp
  32. +26 −9 utils-kt/detritus.lisp
  33. +6 −1 utils-kt/flow-control.lisp
  34. +3 −0  utils-kt/strings.lisp
  35. +6 −11 utils-kt/utils-kt.lpr
View
2  cell-types.lisp
@@ -166,7 +166,7 @@ See the Lisp Lesser GNU Public License for more details.
;__________________
(defmethod c-print-value ((c c-ruled) stream)
- (format stream "~a" (cond ((c-validp c) "<vld>")
+ (format stream "~a" (cond ((c-validp c) (cons (c-value c) "<vld>"))
((c-unboundp c) "<unb>")
((not (c-currentp c)) "dirty")
(t "<err>"))))
View
21 cells-manifesto.txt
@@ -181,7 +181,7 @@ just after CLOS instance initialization, and when a slot changes value. Any obse
is guaranteed to be called at least once during intialization even if a cell slot is bound to a constant
or if it is an input or ruled Cell that never changes value.
-It is legal for observer code to assign to input Cells, but (a) special syntax is required to defer executuion
+It is legal for observer code to assign to input Cells, but (a) special syntax is required to defer execution
until the observed state change has fully propagated; and (b) doing so compromises the declarative
quality of an application -- one can no longer look to one rule to see how a slot (in this case the
input slot being assigned by the observer) gets its value. A reasonable usage might be one with
@@ -205,8 +205,8 @@ When application code assigns to some input cell X, the Cells engine guarantees:
by the change to X and will not be recomputed.
- recomputations, when they read other datapoints, must see only values current with the new value of X.
- Example: if A depends on B and X, and B depends on X, when A reads B it must return a value recomputed from
- the new value of X.
+ Example: if A depends on B and X, and B depends on X, when X changes and A reads B and X to compute a
+ new value, B must return a value recomputed from the new value of X.
- similarly, client observer callbacks must see only values current with the new value of X; and
@@ -285,11 +285,19 @@ C GUI library, where Lisp-land activity must be propagated to the C GUI, and C G
to Lisp-land. See the Cells-Gtk or Celtk projects. Also, a persistent CLOS implementation that must echo
CLOS instance data into, say, SQL tables.
-Prior Art
+Prior Art (in increasing order of priorness (age))
---------
+Functional reactive programming:
+ This looks to be the most active, current, and vibrant subset of folks working on this sort of stuff.
+ Links:
+ FlapJax (FRP-powered web apps) http://www.flapjax-lang.org/
+ http://lambda-the-ultimate.org/node/1771
+ http://www.haskell.org/frp/
+ FrTime (scheme FRP implementation, no great links) http://pre.plt-scheme.org/plt/collects/frtime/doc.txt
+
Adobe Adam, originally developed only to manage complex GUIs. [Adam]
-COSI, a class-based Cells-alike used at STSCI to in software used to
+COSI, a class-based Cells-alike used at STSCI in software used to
schedule Hubble telescope viewing time. [COSI]
Garnet's KR: http://www.cs.cmu.edu/~garnet/
@@ -304,13 +312,12 @@ PhD Thesis in which he develops a constraint programming language or two:
http://www.cs.utk.edu/~bvz/quickplan.html
Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963.
-Steele himself cites Sketchpad as inexlicably unappreciated prior
+Steele himself cites Sketchpad as inexplicably unappreciated prior
art to his Constraints system:
See also:
The spreadsheet paradigm: http://www.cs.utk.edu/~bvz/active-value-spreadsheet.html
The dataflow paradigm: http://en.wikipedia.org/wiki/Dataflow
- Reactive programming: http://www.haskell.org/yampa/AFPLectureNotes.pdf
Frame-based programming
Definitive-programming
View
116 cells-test/cells-test.lpr
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.1 [Windows] (Sep 29, 2007 20:23)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
@@ -25,64 +25,72 @@
:main-form nil
:compilation-unit t
:verbose nil
- :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane
- :cg.bitmap-pane.clipboard :cg.bitmap-stream
- :cg.button :cg.caret :cg.check-box :cg.choice-list
- :cg.choose-printer :cg.clipboard
- :cg.clipboard-stack :cg.clipboard.pixmap
- :cg.color-dialog :cg.combo-box :cg.common-control
- :cg.comtab :cg.cursor-pixmap :cg.curve
- :cg.dialog-item :cg.directory-dialog
- :cg.directory-dialog-os :cg.drag-and-drop
- :cg.drag-and-drop-image :cg.drawable
- :cg.drawable.clipboard :cg.dropping-outline
- :cg.edit-in-place :cg.editable-text
- :cg.file-dialog :cg.fill-texture
- :cg.find-string-dialog :cg.font-dialog
- :cg.gesture-emulation :cg.get-pixmap
- :cg.get-position :cg.graphics-context
- :cg.grid-widget :cg.grid-widget.drag-and-drop
- :cg.group-box :cg.header-control :cg.hotspot
- :cg.html-dialog :cg.html-widget :cg.icon
- :cg.icon-pixmap :cg.ie :cg.item-list
- :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu
- :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget
- :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip
- :cg.message-dialog :cg.multi-line-editable-text
- :cg.multi-line-lisp-text :cg.multi-picture-button
- :cg.multi-picture-button.drag-and-drop
- :cg.multi-picture-button.tooltip :cg.ocx
- :cg.os-widget :cg.os-window :cg.outline
- :cg.outline.drag-and-drop
- :cg.outline.edit-in-place :cg.palette
- :cg.paren-matching :cg.picture-widget
- :cg.picture-widget.palette :cg.pixmap
- :cg.pixmap-widget :cg.pixmap.file-io
- :cg.pixmap.printing :cg.pixmap.rotate :cg.printing
- :cg.progress-indicator :cg.project-window
- :cg.property :cg.radio-button :cg.rich-edit
- :cg.rich-edit-pane :cg.rich-edit-pane.clipboard
- :cg.rich-edit-pane.printing :cg.sample-file-menu
- :cg.scaling-stream :cg.scroll-bar
- :cg.scroll-bar-mixin :cg.selected-object
- :cg.shortcut-menu :cg.static-text :cg.status-bar
- :cg.string-dialog :cg.tab-control
- :cg.template-string :cg.text-edit-pane
- :cg.text-edit-pane.file-io :cg.text-edit-pane.mark
- :cg.text-or-combo :cg.text-widget :cg.timer
- :cg.toggling-widget :cg.toolbar :cg.tooltip
- :cg.trackbar :cg.tray :cg.up-down-control
- :cg.utility-dialog :cg.web-browser
- :cg.web-browser.dde :cg.wrap-string
- :cg.yes-no-list :cg.yes-no-string :dde)
+ :runtime-modules (list :cg-dde-utils :cg.base :cg.bitmap-pane
+ :cg.bitmap-pane.clipboard :cg.bitmap-stream
+ :cg.button :cg.caret :cg.check-box
+ :cg.choice-list :cg.choose-printer
+ :cg.clipboard :cg.clipboard-stack
+ :cg.clipboard.pixmap :cg.color-dialog
+ :cg.combo-box :cg.common-control :cg.comtab
+ :cg.cursor-pixmap :cg.curve :cg.dialog-item
+ :cg.directory-dialog :cg.directory-dialog-os
+ :cg.drag-and-drop :cg.drag-and-drop-image
+ :cg.drawable :cg.drawable.clipboard
+ :cg.dropping-outline :cg.edit-in-place
+ :cg.editable-text :cg.file-dialog
+ :cg.fill-texture :cg.find-string-dialog
+ :cg.font-dialog :cg.gesture-emulation
+ :cg.get-pixmap :cg.get-position
+ :cg.graphics-context :cg.grid-widget
+ :cg.grid-widget.drag-and-drop :cg.group-box
+ :cg.header-control :cg.hotspot :cg.html-dialog
+ :cg.html-widget :cg.icon :cg.icon-pixmap
+ :cg.ie :cg.item-list :cg.keyboard-shortcuts
+ :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane
+ :cg.lisp-text :cg.lisp-widget :cg.list-view
+ :cg.mci :cg.menu :cg.menu.tooltip
+ :cg.message-dialog
+ :cg.multi-line-editable-text
+ :cg.multi-line-lisp-text
+ :cg.multi-picture-button
+ :cg.multi-picture-button.drag-and-drop
+ :cg.multi-picture-button.tooltip :cg.ocx
+ :cg.os-widget :cg.os-window :cg.outline
+ :cg.outline.drag-and-drop
+ :cg.outline.edit-in-place :cg.palette
+ :cg.paren-matching :cg.picture-widget
+ :cg.picture-widget.palette :cg.pixmap
+ :cg.pixmap-widget :cg.pixmap.file-io
+ :cg.pixmap.printing :cg.pixmap.rotate
+ :cg.printing :cg.progress-indicator
+ :cg.project-window :cg.property
+ :cg.radio-button :cg.rich-edit
+ :cg.rich-edit-pane
+ :cg.rich-edit-pane.clipboard
+ :cg.rich-edit-pane.printing
+ :cg.sample-file-menu :cg.scaling-stream
+ :cg.scroll-bar :cg.scroll-bar-mixin
+ :cg.selected-object :cg.shortcut-menu
+ :cg.static-text :cg.status-bar
+ :cg.string-dialog :cg.tab-control
+ :cg.template-string :cg.text-edit-pane
+ :cg.text-edit-pane.file-io
+ :cg.text-edit-pane.mark :cg.text-or-combo
+ :cg.text-widget :cg.timer :cg.toggling-widget
+ :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray
+ :cg.up-down-control :cg.utility-dialog
+ :cg.web-browser :cg.web-browser.dde
+ :cg.wrap-string :cg.yes-no-list
+ :cg.yes-no-string :dde)
:splash-file-module (make-instance 'build-module :name "")
:icon-file-module (make-instance 'build-module :name "")
- :include-flags '(:top-level :debugger)
- :build-flags '(:allow-runtime-debug :purify)
+ :include-flags (list :top-level :debugger)
+ :build-flags (list :allow-runtime-debug :purify)
:autoload-warning t
:full-recompile-for-runtime-conditionalizations nil
+ :include-manifest-file-for-visual-styles t
:default-command-line-arguments "+M +t \"Console for Debugging\""
- :additional-build-lisp-image-arguments '(:read-init-files nil)
+ :additional-build-lisp-image-arguments (list :read-init-files nil)
:old-space-size 256000
:new-space-size 6144
:runtime-build-option :standard
View
10 cells-test/deep-cells.lisp
@@ -34,12 +34,12 @@
(setf *client-log* (append *client-log* (list new-value))))))
(defun deep-queue-handler (client-q)
- (loop for (nil . task) in (prog1
- (sort (fifo-data client-q) '< :key 'car)
- (fifo-clear client-q))
- do
+ (loop for (defer-info . task) in (prog1
+ (sort (fifo-data client-q) '< :key 'car)
+ (fifo-clear client-q))
+ do
(trc nil "!!! --- deep-queue-handler dispatching" defer-info)
- (funcall task)))
+ (funcall task :user-q defer-info)))
(def-cell-test go-deep ()
(cells-reset 'deep-queue-handler)
View
23 cells-test/test-synapse.lisp
@@ -33,6 +33,29 @@
(defobserver m-syn-b ()
(print `(output m-syn-b ,self ,new-value ,old-value)))
+(def-cell-test m-syn-bool
+ (let* ((delta-ct 0)
+ (m (make-instance 'm-syn
+ :m-syn-a (c-in nil)
+ :m-syn-b (c? (incf delta-ct)
+ (trc "syn-b containing rule firing!!!!!!!!!!!!!!" delta-ct)
+ (bwhen (msg (with-synapse :xyz42 ()
+ (trc "synapse fires!!! ~a" (^m-syn-a))
+ (bIF (k (find (^m-syn-a) '(:one :two :three)))
+ (values k :propagate)
+ (values NIL :no-propagate))))
+ msg)))))
+ (ct-assert (= 1 delta-ct))
+ (ct-assert (null (m-syn-b m)))
+ (setf (m-syn-a m) :nine)
+ (ct-assert (= 1 delta-ct))
+ (ct-assert (null (m-syn-b m)))
+ (setf (m-syn-a m) :one)
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (eq :one (m-syn-b m)))
+ (setf (m-syn-a m) :nine)
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (eq :one (m-syn-b m)))))
(def-cell-test m-syn
(let* ((delta-ct 0)
View
2  cells-test/test.lisp
@@ -68,8 +68,10 @@ subclass for them?)
#+go
(test-cells)
+
(defun test-cells ()
(loop for test in (reverse *cell-tests*)
+ when (eq 'm-syn-bool test)
do (cell-test-init test)
(funcall test))
(print (make-string 40 :initial-element #\*))
View
12 cells.lisp
@@ -19,8 +19,12 @@ See the Lisp Lesser GNU Public License for more details.
(eval-when (compile load)
(proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))))
+
+
(in-package :cells)
+
+
(defparameter *c-prop-depth* 0)
(defparameter *causation* nil)
@@ -32,6 +36,9 @@ See the Lisp Lesser GNU Public License for more details.
(defparameter *client-queue-handler* nil)
(defparameter *unfinished-business* nil)
+#+test
+(cells-reset)
+
(defun cells-reset (&optional client-queue-handler &key debug)
(utils-kt-reset)
(setf
@@ -55,6 +62,11 @@ See the Lisp Lesser GNU Public License for more details.
(defun c-stopped ()
*stop*)
+(export! .stopped)
+
+(define-symbol-macro .stopped
+ (c-stopped))
+
(defmacro c-assert (assertion &optional places fmt$ &rest fmt-args)
(declare (ignorable assertion places fmt$ fmt-args))
#+(or)`(progn)
View
4 cells.lpr
@@ -1,8 +1,8 @@
-;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Sep 14, 2007 21:56)"; cg: "1.81"; -*-
(in-package :cg-user)
-(defpackage :CELLS)
+(defpackage :cells)
(define-project :name :cells
:modules (list (make-instance 'module :name "defpackage.lisp")
View
9 constructors.lisp
@@ -26,7 +26,7 @@ See the Lisp Lesser GNU Public License for more details.
(defmacro c-lambda (&body body)
`(c-lambda-var (slot-c) ,@body))
-(export! .cache-bound-p)
+(export! .cache-bound-p c?+n)
(defmacro c-lambda-var ((c) &body body)
`(lambda (,c &aux (self (c-model ,c))
@@ -49,6 +49,13 @@ See the Lisp Lesser GNU Public License for more details.
:value-state :unevaluated
:rule (c-lambda ,@body)))
+(defmacro c?+n (&body body)
+ `(make-c-dependent
+ :inputp t
+ :code ',body
+ :value-state :unevaluated
+ :rule (c-lambda ,@body)))
+
(defmacro c?n (&body body)
`(make-c-dependent
:code '(without-c-dependency ,@body)
View
4 defmodel.lisp
@@ -17,7 +17,6 @@ See the Lisp Lesser GNU Public License for more details.
|#
(in-package :cells)
-
(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)
@@ -197,3 +196,6 @@ the defmodel form for ~a" ',class ',class))))
(ddd (c-in nil) :cell :ephemeral)
:superx 42 ;; default-initarg
(:documentation "as if!")))
+
+
+
View
2  defpackage.lisp
@@ -58,6 +58,6 @@
#:fm-kid-containing #:fm-find-if #:fm-ascendant-if #:c-abs #:fm-collect-if #:psib
#:not-to-be #:ssibno
#:c-debug #:c-break #:c-assert #:c-stop #:c-stopped #:c-assert #:.stop #:delta-diff
- )
+ #:wtrc #:wnotrc #:eko-if #:trc #:wtrc #:eko #:ekx #:trcp #:trcx)
#+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc)
)
View
1  family.lisp
@@ -28,7 +28,6 @@ See the Lisp Lesser GNU Public License for more details.
(.value :initform nil :accessor value :initarg :value)
(zdbg :initform nil :accessor dbg :initarg :dbg)))
-
(defmethod fm-parent (other)
(declare (ignore other))
nil)
View
54 fm-utilities.lisp
@@ -87,11 +87,11 @@ See the Lisp Lesser GNU Public License for more details.
(or (funcall some-function parent)
(fm-ascendant-some (fm-parent parent) some-function))))
-(defun fm-ascendant-if (self if-function)
- (when (and self if-function)
- (or (when (funcall if-function self)
+(defun fm-ascendant-if (self test)
+ (when (and self test)
+ (or (when (funcall test self)
self)
- (fm-ascendant-if .parent if-function))))
+ (fm-ascendant-if .parent test))))
(defun fm-descendant-if (self test)
(when (and self test)
@@ -105,11 +105,13 @@ See the Lisp Lesser GNU Public License for more details.
(when (fm-includes node d2)
node))))
-(defun fm-collect-if (tree test)
+(defun fm-collect-if (tree test &optional skip-top dependently)
(let (collection)
(fm-traverse tree (lambda (node)
- (when (funcall test node)
- (push node collection))))
+ (unless (and skip-top (eq node tree))
+ (when (funcall test node)
+ (push node collection))))
+ :with-dependency dependently)
(nreverse collection)))
(defun fm-value-dictionary (tree value-fn &optional include-top)
@@ -159,6 +161,39 @@ See the Lisp Lesser GNU Public License for more details.
(without-c-dependency (tv))))))
(values))
+(export! fm-traverse-bf)
+(defun fm-traverse-bf (family applied-fn &optional (cq (make-fifo-queue)))
+ (when family
+ (flet ((process-node (fm)
+ (funcall applied-fn fm)
+ (when (kids fm)
+ (fifo-add cq (kids fm)))))
+ (process-node family)
+ (loop for x = (fifo-pop cq)
+ while x
+ do (mapcar #'process-node x)))))
+
+#+test-bf
+(progn
+ (defmd bftree (family)
+ (depth 0 :cell nil)
+ (id (c? (klin self)))
+ :kids (c? (when (< (depth self) 4)
+ (loop repeat (1+ (depth self))
+ collecting (make-kid 'bftree :depth (1+ (depth self)))))))
+
+ (defun klin (self)
+ (when self
+ (if .parent
+ (cons (kid-no self) (klin .parent))
+ (list 0))))
+
+ (defun test-bf ()
+ (let ((self (make-instance 'bftree)))
+ (fm-traverse-bf self
+ (lambda (node)
+ (print (id node)))))))
+
(defun fm-ordered-p (n1 n2 &aux (top (fm-ascendant-common n1 n2)))
(assert top)
(fm-traverse top (lambda (n)
@@ -213,7 +248,7 @@ See the Lisp Lesser GNU Public License for more details.
;; should be modified to go through 'gather', which should be the real fm-find-all
;;
-(export! fm-do-up)
+(export! fm-do-up fm-find-next fm-find-prior)
(defun fm-do-up (self &optional (fn 'identity))
(when self
@@ -554,7 +589,8 @@ See the Lisp Lesser GNU Public License for more details.
(count-it :fm-find-one)
(flet ((matcher (fm)
(when diag
- (trc "fm-find-one matcher sees name" (md-name fm) :ofthing fm :seeking md-name))
+ (trc nil
+ "fm-find-one matcher sees name" (md-name fm) :ofthing (type-of fm) :seeking md-name global-search))
(when (and (eql (name-root md-name)(md-name fm))
(or (null (name-subscript md-name))
(eql (name-subscript md-name) (fm-pos fm)))
View
2  gui-geometry/geo-data-structures.lisp
@@ -17,7 +17,7 @@ See the Lisp Lesser GNU Public License for more details.
(in-package :gui-geometry)
(eval-now!
- (export '(v2 mkv2)))
+ (export '(v2 mkv2 v2=)))
;-----------------------------
(defstruct v2
View
67 gui-geometry/geo-family.lisp
@@ -102,6 +102,47 @@ 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)
+ (not (collapsed sib)))))
+ (eko (nil "^prior-sib-pb spc pb-psib -lt" (- (abs spacing)) (pb psib) (- (^lt)))
+ (+ (- (abs spacing)) ;; force spacing to minus(= down for OpenGL)
+ (pb psib)))
+ 0))
+
+(defun centered-h? ()
+ (c? (px-maintain-pl (round (- (inset-width .parent) (l-width self)) 2))))
+
+(defun centered-v? ()
+ (c? (py-maintain-pt (round (- (l-height .parent) (l-height self)) -2))))
+
+;--------------- geo.row.flow ----------------------------
+(export! geo-row-flow)
+
+(defmodel geo-row-flow (geo-inline)
+ ((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz)
+ (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt)
+ (aligned :cell nil :initarg :aligned :initform nil :reader aligned))
+ (:default-initargs
+ :lb (c? (geo-kid-wrap self 'pb))
+ :kid-slots (lambda (self)
+ (declare (ignore self))
+
+ (list
+ (mk-kid-slot (py)
+ (c? (py-maintain-pt
+ (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent))))
+ (if (> (+ ph (l-width self)(outset .parent)) (l-width .parent))
+ (^prior-sib-pb self (spacing-vt .parent))
+ (^prior-sib-pt self))))))
+ (mk-kid-slot (px)
+ (c? (px-maintain-pl
+ (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent))))
+ (if (> (+ ph (l-width self)(outset .parent)) (l-width .parent))
+ 0
+ ph)))))))))
+
#| archive
(defmodel geo-row-fv (family-values geo-row)())
@@ -136,28 +177,8 @@ See the Lisp Lesser GNU Public License for more details.
(pt psib))
0))))))))
-;--------------- IGRowFlow ----------------------------
+|#
+
+
-(defmodel geo-row-flow (geo-row)
- ((spacing-hz :cell nil :initarg :spacing-hz :initform 0 :reader spacing-hz)
- (spacing-vt :cell nil :initarg :spacing-vt :initform 0 :reader spacing-vt)
- (aligned :cell nil :initarg :aligned :initform nil :reader aligned))
- (:default-initargs
- :lb (c? (geo-kid-wrap self 'pb))
- :kid-slots (lambda (self)
- (declare (ignore self))
- (list
- (mk-kid-slot (py)
- (c? (py-maintain-pt
- (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent))))
- (if (> (+ ph (l-width self)) (l-width .parent))
- (^prior-sib-pb self (spacing-vt .parent))
- (^prior-sib-pt self))))))
- (mk-kid-slot (px)
- (c? (px-maintain-pl
- (let ((ph (^prior-sib-pr self (spacing-hz .parent) (aligned .parent))))
- (if (> (+ ph (l-width self)) (l-width .parent))
- 0
- ph)))))))))
-|#
View
135 gui-geometry/geometer.lisp
@@ -87,18 +87,7 @@ See the Lisp Lesser GNU Public License for more details.
;(trc "inner outer" inner outer)
))
-(defmacro ^offset-within (inner outer)
- (let ((offset-h (gensym)) (offset-v (gensym)) (from (gensym)))
- `(let ((,offset-h 0)
- (,offset-v 0))
- (do ((,from ,inner (fm-parent ,from)))
- ((or (null ,from)
- (eql ,from ,outer))
- ;
- (mkv2 ,offset-h ,offset-v))
-
- (incf ,offset-h (px ,from))
- (incf ,offset-v (py ,from))))))
+
;----------- OfKids -----------------------
;
@@ -127,6 +116,8 @@ See the Lisp Lesser GNU Public License for more details.
(v2-subtract outer-v2
(mkv2 (px inner) (py inner))))))
+(export! h-xlate v-xlate)
+
(defun h-xlate (outer inner outer-h)
(if (eql outer inner)
outer-h
@@ -212,18 +203,6 @@ See the Lisp Lesser GNU Public License for more details.
;---------------------------------
-(defmacro ^ll-width (width)
- `(- (lr self) ,width))
-
-(defmacro ^lr-width (width)
- `(+ (ll self) ,width))
-
-(defmacro ^lt-height (height)
- `(- (lb self) ,height))
-
-(defmacro ^lb-height (height)
- `(+ (lt self) ,height))
-
;----------------------------------
(export! geo-kid-wrap)
@@ -235,108 +214,6 @@ See the Lisp Lesser GNU Public License for more details.
((pr pt) 'fm-max-kid)) self bound)
(outset self)))
-(defmacro ll-maintain-pL (pl)
- `(- ,pL (^px)))
-
-(defmacro lr-maintain-pr (pr)
- `(- ,pr (^px)))
-
-(defmacro ^fill-right (upperType &optional (padding 0))
- `(call-^fillRight self (upper self ,upperType) ,padding))
-
-;recalc local top based on pT and offset
-(defmacro lt-maintain-pT (pT)
- `(- ,pT (^py)))
-
-;recalc local bottom based on pB and offset
-(defmacro lb-maintain-pB (pB)
- `(- ,pB (^py)))
-
-;--------------
-;recalc offset based on p and local
-(defmacro px-maintain-pL (pL)
- (let ((lL (gensym)))
- `(- ,pL (let ((,lL (^lL)))
- (c-assert ,lL () "^px-maintain-pL sees nil lL for ~a" self)
- ,lL))))
-
-(defmacro px-maintain-pR (pR)
- `(- ,pR (^lR)))
-
-(defmacro py-maintain-pT (pT)
- `(- ,pT (^lT)))
-
-(defmacro py-maintain-pB (pB)
- `(- ,pB (^lB)))
-
-(defmacro centered-h? ()
- `(c? (px-maintain-pl (round (- (l-width .parent) (l-width self)) 2))))
-
-(defmacro ^centered-v? ()
- `(c? (py-maintain-pt (round (- (l-height .parent) (l-height self)) 2))))
-
-(defmacro ^fill-down (upper-type &optional (padding 0))
- (let ((filled (gensym)))
- `(let ((,filled (upper self ,upper-type)))
- #+qt (trc "^fillDown sees filledLR less offH"
- (lb ,filled)
- ,padding
- (v2-v (offset-within self ,filled)))
- (- (lb ,filled)
- ,padding
- (v2-v (offset-within self ,filled))))))
-
-(defmacro ^lbmax? (&optional (padding 0))
- `(c? (lb-maintain-pb (- (inset-lb .parent)
- ,padding))))
-
-(defmacro ^lrmax? (&optional (padding 0))
- `(c? (lr-maintain-pr (- (inset-lr .parent)
- ,padding))))
-
-(defun ^prior-sib-pb (self &optional (spacing 0))
- (bif (psib (find-prior self (kids .parent)
- :test (lambda (sib)
- (not (collapsed sib)))))
- (eko (nil "^prior-sib-pb spc pb-psib -lt" (- (abs spacing)) (pb psib) (- (^lt)))
- (+ (- (abs spacing)) ;; force spacing to minus(= down for OpenGL)
- (pb psib)))
- 0))
-
-(defmacro ^prior-sib-pt (self &optional (spacing 0))
- (let ((kid (gensym))
- (psib (gensym)))
- `(let* ((,kid ,self)
- (,psib (find-prior ,kid (kids (fm-parent ,kid)))))
- ;(trc "^priorSib-pb > kid, sib" ,kid ,pSib)
- (if ,psib
- (+ (- (abs ,spacing)) (pt ,psib))
- 0))))
-
-; "...return the sib's pL [if ,alignment is :left] or pR, plus optional spacing"
-
-(defmacro ^prior-sib-pr (self &optional (spacing 0) alignment)
- (let ((kid (gensym))
- (psib (gensym)))
- `(let* ((,kid ,self)
- (,psib (find-prior ,kid (kids (fm-parent ,kid)) :test (lambda (k) (not (collapsed k))))))
- (if ,psib
- (case ,alignment
- (:left (+ ,spacing (pl ,psib)))
- (otherwise (+ ,spacing (pr ,psib))))
- 0))))
-
-(defmacro ^px-stay-right-of (other &key (by '0))
- `(px-maintain-pl (+ (pr (fm-other ,other)) ,by)))
-
-; in use; adjust offset to maintain pL based on ,justify
-(defmacro ^px-self-centered (justify)
- `(px-maintain-pl
- (ecase ,justify
- (:left 0)
- (:center (floor (- (inset-width .parent) (l-width self)) 2))
- (:right (- (inset-lr .parent) (l-width self))))))
-
; in use; same idea for pT
(defun py-self-centered (self justify)
(py-maintain-pt
@@ -345,9 +222,3 @@ See the Lisp Lesser GNU Public License for more details.
(:center (floor (- (inset-height .parent) (l-height self)) -2))
(:bottom (downs (- (inset-height .parent) (l-height self)))))))
-(defmacro ^fill-parent-right (&optional (inset 0))
- `(lr-maintain-pr (- (inset-lr .parent) ,inset)))
-
-(defmacro ^fill-parent-down ()
- `(lb-maintain-pb (inset-lb .parent)))
-
View
3  gui-geometry/gui-geometry.lpr
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jan 29, 2007 18:02)"; cg: "1.81"; -*-
(in-package :cg-user)
@@ -6,6 +6,7 @@
(define-project :name :gui-geometry
:modules (list (make-instance 'module :name "defpackage.lisp")
+ (make-instance 'module :name "geo-macros.lisp")
(make-instance 'module :name
"geo-data-structures.lisp")
(make-instance 'module :name "coordinate-xform.lisp")
View
38 integrity.lisp
@@ -44,6 +44,9 @@ See the Lisp Lesser GNU Public License for more details.
*within-integrity*)
(defun call-with-integrity (opcode defer-info action)
+ (when (eq opcode :change)
+ (when (eq defer-info :focus)
+ (break "cwi focus change")))
(when *stop*
(return-from call-with-integrity))
(if *within-integrity*
@@ -76,7 +79,7 @@ See the Lisp Lesser GNU Public License for more details.
(defun ufb-add (opcode continuation)
(assert (find opcode *ufb-opcodes*))
- (when (and *no-tell* (eq opcode :tell-dependents))
+ #+trythis (when (and *no-tell* (eq opcode :tell-dependents))
(break "truly queueing tell under no-tell"))
(trc nil "ufb-add deferring" opcode (when (eql opcode :client)(car continuation)))
(fifo-add (ufb-queue-ensure opcode) continuation))
@@ -109,27 +112,38 @@ See the Lisp Lesser GNU Public License for more details.
;
(bwhen (uqp (fifo-peek (ufb-queue :tell-dependents)))
(trcx finish-business uqp)
- (DOlist (b (fifo-data (ufb-queue :tell-dependents)))
+ (dolist (b (fifo-data (ufb-queue :tell-dependents)))
(trc "unhandled :tell-dependents" (car b) (c-callers (car b))))
(break "unexpected 1> ufb needs to tell dependnents after telling dependents"))
(let ((*no-tell* t))
(just-do-it :awaken) ;--- md-awaken new instances ---
- )
+ )
;
- ; we do not go back to check for a need to :tell-dependents because (a) the original propagation
+ ; OLD THINKING, preserved for the record, but NO LONGER TRUE:
+ ; 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 there can be no dependents
; to "tell". I think. :) So...
+ ; END OF OLD THINKING
;
+ ; We now allow :awaken to change things so more dependents need to be told. The problem is the implicit
+ ; dependence on the /life/ of a model whenever there is a dependence on any /cell/ of that model.
+ ; md-quiesce currently just flags such slots as uncurrent -- maybe /that/ should change and those should
+ ; recalculate at once -- and then an /observer/ can run and ask for a new value from such an uncurrent cell,
+ ; which now knows it must recalculate. And that recalculation of course can and likely will come up with a new value
+ ; and perforce need to tell its dependents. So...
+ ;
+ ; I /could/ explore something other than the "uncurrent" kludge, but NCTM 2007 is coming up and
+ ; to be honest the idea of not allowing nested tells was enforcing a /guess/ that that should not
+ ; arise, and there was not even any perceived integrity whole being closed, it was just a gratuitous
+ ; QA trick, and indeed for a long time many nested tells were avoidable. But the case of the quiesced
+ ; 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)))
- (trcx finish-business uqp)
- (DOlist (b (fifo-data (ufb-queue :tell-dependents)))
- (trc "unhandled :tell-dependents" (car b) (c-callers (car b))))
- (break "unexpected 2> ufb needs to tell dependnents after awakening"))
-
- (assert (null (fifo-peek (ufb-queue :tell-dependents))))
-
+ (trc "retelling dependenst, one new one being" uqp)
+ (go tell-dependents))
+
;--- process client queue ------------------------------
;
(when *stop* (return-from finish-business))
@@ -141,7 +155,7 @@ See the Lisp Lesser GNU Public License for more details.
(just-do-it clientq))
(when (fifo-peek (ufb-queue :client))
#+shhh (ukt::fifo-browse (ufb-queue :client) (lambda (entry)
- (trc "surprise client" entry)))
+ (trc "surprise client" entry)))
(go handle-clients)))
;--- now we can reset ephemerals --------------------
;
View
3  link.lisp
@@ -67,7 +67,8 @@ See the Lisp Lesser GNU Public License for more details.
(zerop (sbit usage rpos)))
(progn
(count-it :unlink-unused)
- (trc nil "c-unlink-unused" c :dropping-used (car useds))
+ #+save (when (eq 'mathx::progress (c-slot-name c))
+ (trc "c-unlink-unused" c :dropping-used (car useds)) )
(c-unlink-caller (car useds) c)
(rplaca useds nil))
(progn
View
42 md-slot-value.lisp
@@ -64,6 +64,8 @@ See the Lisp Lesser GNU Public License for more details.
;;; (mathx::show-time t)
;;; (ctk::app-time t))))
+(defvar *trc-ensure* nil)
+
(defun ensure-value-is-current (c debug-id ensurer)
;
; ensurer can be used cell propagating to callers, or an existing caller who wants to make sure
@@ -78,7 +80,7 @@ See the Lisp Lesser GNU Public License for more details.
(cond
((c-currentp c)
- (trc nil "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete
+ (trc nil "EVIC yep: c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete
;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete
;;
((and (c-inputp c)
@@ -100,15 +102,23 @@ See the Lisp Lesser GNU Public License for more details.
(or (check-reversed (cdr useds))
(let ((used (car useds)))
(ensure-value-is-current used :nested c)
- (trc nil "comparing pulses (ensurer, used, used-changed): " c debug-id used (c-pulse-last-changed used))
+ #+slow (trc c "comparing pulses (ensurer, 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)
+ #+slow (trc c "used changed and newer !!!!!!" c :oldpulse (c-pulse used) debug-id used :lastchg (c-pulse-last-changed used))
+ #+shhh (when (trcp c)
+ (describe used))
t))))))
(assert (typep c 'c-dependent))
(check-reversed (cd-useds c))))
- (trc nil "kicking off calc-set of" (c-slot-name c) :pulse *data-pulse-id*)
+ #+slow (trc c "kicking off calc-set of" (c-validp c) (c-slot-name c) :vstate (c-value-state c)
+ :stamped (c-pulse c) :current-pulse *data-pulse-id*)
(calculate-and-set c))
+ ((mdead (c-value c))
+ (trc "ensure-value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c))
+ (let ((new-v (calculate-and-set c)))
+ (trc "ensure-value-is-current> GOT new value ~a" new-v)))
+
(t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) debug-id)
(c-pulse-update c :valid-uninfluenced)))
@@ -118,7 +128,7 @@ See the Lisp Lesser GNU Public License for more details.
(bwhen (v (c-value c))
(if (mdead v)
(progn
- (trc "ensure-value not returning dead model object value" v)
+ (brk "ensure-value still got and still not returning ~a dead value ~a" c v)
nil)
v)))
@@ -127,7 +137,8 @@ See the Lisp Lesser GNU Public License for more details.
(when (c-stopped)
(princ #\.)
(return-from calculate-and-set))
-
+
+ #-its-alive!
(bwhen (x (find c *call-stack*)) ;; circularity
(unless nil ;; *stop*
(let ((stack (copy-list *call-stack*)))
@@ -142,7 +153,7 @@ See the Lisp Lesser GNU Public License for more details.
(setf caller-reiterated (eq caller c)))
(c-break ;; break is problem when testing cells on some CLs
"cell ~a midst askers (see above)" c)
- (break))
+ (break "see listener for cell rule cycle diagnotics"))
(multiple-value-bind (raw-value propagation-code)
(calculate-and-link c)
@@ -160,7 +171,7 @@ See the Lisp Lesser GNU Public License for more details.
(let ((*call-stack* (cons c *call-stack*))
(*defer-changes* t))
(assert (typep c 'c-ruled))
- (trc nil "calculate-and-link" c)
+ #+slow (trc *c-debug* "calculate-and-link" c)
(cd-usage-clear-all c)
(multiple-value-prog1
(funcall (cr-rule c) c)
@@ -248,7 +259,7 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
; --- head off unchanged; this got moved earlier on 2006-06-10 ---
(when (and (not (eq propagation-code :propagate))
- (eql prior-state :valid)
+ (find prior-state '(:valid :uncurrent))
(c-no-news c absorbed-value prior-value))
(trc nil "(setf md-slot-value) > early no news" propagation-code prior-state prior-value absorbed-value)
(count-it :nonews)
@@ -303,16 +314,23 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
(setf (c-state c) :optimized-away)
- (let ((entry (rassoc c (cells (c-model c))))) ; move from cells to cells-flushed
+ (let ((entry (rassoc c (cells (c-model c)))))
(unless entry
(describe c))
(c-assert entry)
(trc nil "c-optimize-away?! moving cell to flushed list" c)
(setf (cells (c-model c)) (delete entry (cells (c-model c))))
- (push entry (cells-flushed (c-model c))))
+ #-its-alive! (push entry (cells-flushed (c-model c)))
+ )
(dolist (caller (c-callers c))
- (break "got opti of called")
+ ;
+ ; example: on window shutdown with a tool-tip displayed, the tool-tip generator got
+ ; kicked off and asked about the value of a dead instance. That returns nil, and
+ ; there was no other dependency, so the Cell then decided to optimize itself away.
+ ; of course, before that time it had a normal value on which other things depended,
+ ; so we ended up here. where there used to be a break.
+ ;
(setf (cd-useds caller) (delete c (cd-useds caller)))
(c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...)
)))
View
26 md-utilities.lisp
@@ -33,7 +33,7 @@ See the Lisp Lesser GNU Public License for more details.
(defgeneric mdead (self)
(:method ((self model-object))
- (eq :eternal-rest (md-state SELF)))
+ (eq :eternal-rest (md-state self)))
(:method (self)
(declare (ignore self))
@@ -47,19 +47,19 @@ See the Lisp Lesser GNU Public License for more details.
(:method :around ((self model-object))
(declare (ignorable self))
(trc nil #+not (typep self '(or mathx::problem mathx::prb-solvers mathx::prb-solver))
- "not-to-be nailing" self)
- (c-assert (not (eq (md-state self) :eternal-rest)))
+ "not.to-be nailing" self)
+ ;;showpanic (c-assert (not (eq (md-state self) :eternal-rest)))
+ (unless (eq (md-state self) :eternal-rest)
+ (call-next-method)
- (call-next-method)
+ (setf (fm-parent self) nil
+ (md-state self) :eternal-rest)
- (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)
- (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)))
+ (trc nil "not.to-be cleared 2 fm-parent, eternal-rest" self))))
(defun md-quiesce (self)
(trc nil "md-quiesce nailing cells" self (type-of self))
@@ -75,13 +75,11 @@ See the Lisp Lesser GNU Public License for more details.
(c-unlink-from-used c)
(dolist (caller (c-callers c))
(setf (c-value-state caller) :uncurrent)
- (trc nil "c-quiesce unlinking caller" c)
+ (trc nil "c-quiesce unlinking caller and making uncurrent" :q c :caller caller)
(c-unlink-caller c caller))
(setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho
)))
-
-
(defparameter *to-be-dbg* nil)
(defmacro make-kid (class &rest initargs)
View
10 model-object.lisp
@@ -143,8 +143,11 @@ See the Lisp Lesser GNU Public License for more details.
;; next is an indirect and brittle way to determine that a slot has already been output,
;; but I think anything better creates a run-time hit.
;;
- (unless (md-slot-cell-flushed self slot-name) ;; slot will have been propagated just after cell was flushed
- (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil)))
+ ;; until 2007-10 (unless (cdr (assoc slot-name (cells-flushed self))) ;; make sure not flushed
+ ;; but first I worried about it being slow keeping the flushed list /and/ searching, then
+ ;; I wondered why a flushed cell should not be observed, constant cells are. So Just Observe It
+ (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil))
+
((find (c-lazy c) '(:until-asked :always t))
(trc nil "md-awaken deferring c-awaken since lazy"
@@ -224,9 +227,6 @@ See the Lisp Lesser GNU Public License for more details.
(setf (slot-value self slot-name) new-value)
(setf (symbol-value slot-name) new-value)))
-(defun md-slot-cell-flushed (self slot-name)
- (cdr (assoc slot-name (cells-flushed self))))
-
;----------------- navigation: slot <> initarg <> esd <> cell -----------------
#+cmu
View
30 propagate.lisp
@@ -46,7 +46,8 @@ See the Lisp Lesser GNU Public License for more details.
(defun c-pulse-update (c key)
(declare (ignorable key))
- (trc nil "!!!!!!! c-pulse-update updating !!!!!!!!!!" *data-pulse-id* c key :prior-pulse (c-pulse c))
+ (unless (find key '(:valid-uninfluenced))
+ (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*))
@@ -74,7 +75,7 @@ See the Lisp Lesser GNU Public License for more details.
(princ #\.)(princ #\!)
(return-from c-propagate))
(trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)))
- (trc nil "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c)
+ #+slow (trc c "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c)
(when *c-debug*
(when (> *c-prop-depth* 250)
(trc nil "c-propagate deep" *c-prop-depth* (c-model c) (c-slot-name c) #+nah c))
@@ -83,7 +84,7 @@ See the Lisp Lesser GNU Public License for more details.
; --- manifest new value as needed ---
;
- ; 20061030 Trying not-to-be first because doomed instances may be interested in callers
+ ; 20061030 Trying not.to.be first because doomed instances may be interested in callers
; who will decide to propagate. If a family instance kids slot is changing, a doomed kid
; will be out of the kids but not yet quiesced. If the propagation to this rule asks the kid
; to look at its siblings (say a view instance being deleted from a stack who looks to the psib
@@ -95,7 +96,7 @@ See the Lisp Lesser GNU Public License for more details.
(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))))
+ (bif (lost (set-difference (listify prior-value) (listify (c-value c))))
(progn
(trc nil "prop nailing owned!!!!!!!!!!!" c :lost lost :leaving (c-value c))
(mapcar 'not-to-be lost))
@@ -169,6 +170,8 @@ See the Lisp Lesser GNU Public License for more details.
; --- recalculate dependents ----------------------------------------------------
+
+
(defun c-propagate-to-callers (c)
;
; We must defer propagation to callers because of an edge case in which:
@@ -186,26 +189,27 @@ See the Lisp Lesser GNU Public License for more details.
(member (c-lazy caller) '(t :always :once-asked))))
(c-callers c))
(let ((causation (cons c *causation*))) ;; in case deferred
- (TRC nil "c-propagate-to-callers > queueing notifying callers" (c-callers c))
+ #+slow (TRC c "c-propagate-to-callers > queueing notifying callers" (c-callers c))
(with-integrity (:tell-dependents c)
(assert (null *call-stack*))
(let ((*causation* causation))
(trc nil "c-propagate-to-callers > actually notifying callers of" c (c-callers c))
#+c-debug (dolist (caller (c-callers c))
(assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller))
- (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list...
- (trc nil "PRE-prop-CHECK " c :caller caller (c-state caller) (c-lazy caller))
- (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced
- (member (c-lazy caller) '(t :always :once-asked)))
- (assert (find c (cd-useds caller))() "Precheck Caller ~a of ~a does not have it as used" caller c)
- ))
+ #+c-debug (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list...
+ (trc nil "PRE-prop-CHECK " c :caller caller (c-state caller) (c-lazy caller))
+ (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced
+ (member (c-lazy caller) '(t :always :once-asked)))
+ (assert (find c (cd-useds caller))() "Precheck Caller ~a of ~a does not have it as used" caller c)
+ ))
(dolist (caller (progn #+not copy-list (c-callers c))) ;; following code may modify c-callers list...
(trc nil "propagating to caller iterates" c :caller caller (c-state caller) (c-lazy caller))
(unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced
(member (c-lazy caller) '(t :always :once-asked)))
(assert (find c (cd-useds caller))() "Caller ~a of ~a does not have it as used" caller c)
- (trc nil "propagating to caller is used" c :caller caller)
- (ensure-value-is-current caller :prop-from c))))))))
+ #+slow (trc c "propagating to caller is used" c :caller caller (c-currentp c))
+ (let ((*trc-ensure* (trcp c)))
+ (ensure-value-is-current caller :prop-from c)))))))))
View
12 synapse-types.lisp
@@ -18,6 +18,18 @@ See the Lisp Lesser GNU Public License for more details.
(in-package :cells)
+(export! f-find)
+
+(defmacro f-find (synapse-id sought where)
+ `(call-f-find ,synapse-id ,sought ,where))
+
+(defun call-f-find (synapse-id sought where)
+ (with-synapse synapse-id ()
+ (bif (k (progn
+ (find sought where)))
+ (values k :propagate)
+ (values nil :no-propagate))))
+
(defmacro f-sensitivity (synapse-id (sensitivity &optional subtypename) &body body)
`(call-f-sensitivity ,synapse-id ,sensitivity ,subtypename (lambda () ,@body)))
View
3  synapse.lisp
@@ -19,7 +19,7 @@ See the Lisp Lesser GNU Public License for more details.
(in-package :cells)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent)))
+ (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent with-synapse)))
(defmacro with-synapse (synapse-id (&rest closure-vars) &body body)
(let ((syn-id (gensym))(syn-caller (gensym)))
@@ -40,7 +40,6 @@ See the Lisp Lesser GNU Public License for more details.
(multiple-value-bind (v p)
(with-integrity ()
(ensure-value-is-current synapse :synapse (car *call-stack*)))
- (trc nil "with-synapse: synapse, v, prop" synapse v p)
(values v p))
(record-caller synapse)))))
View
1  test-synapse.lisp
@@ -35,6 +35,7 @@
(print `(output m-syn-b ,self ,new-value ,old-value)))
+
(def-cell-test m-syn
(progn (cell-reset)
(let* ((delta-ct 0)
View
36 trc-eko.lisp
@@ -22,8 +22,6 @@ See the Lisp Lesser GNU Public License for more details.
(defparameter *trcdepth* 0)
-(export! trc wtrc eko)
-
(defun trcdepth-reset ()
(setf *trcdepth* 0))
@@ -35,18 +33,31 @@ See the Lisp Lesser GNU Public License for more details.
`(without-c-dependency
(call-trc t ,tgt-form ,@os))
(let ((tgt (gensym)))
+ ;(break "slowww? ~a" tgt-form)
`(without-c-dependency
(bif (,tgt ,tgt-form)
(if (trcp ,tgt)
(progn
- (assert (stringp ,(car os)))
+ (assert (stringp ,(car os)) () "trc with test expected string second, got ~a" ,(car os))
(call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os)))
(progn
- ;; (break "trcfailed")
+ ;(trc "trcfailed")
(count-it :trcfailed)))
(count-it :tgtnileval)))))))
-(export! trcx)
+(export! brk brkx .bgo)
+
+
+(define-symbol-macro .bgo (break "go"))
+
+(defun brk (&rest args)
+ #+its-alive! (print args)
+ #-its-alive! (progn
+ ;;(setf *ctk-dbg* t)
+ (apply 'break args)))
+
+(defmacro brkx (msg)
+ `(break "At ~a: OK?" ',msg))
(defmacro trcx (tgt-form &rest os)
(if (eql tgt-form 'nil)
@@ -60,6 +71,7 @@ See the Lisp Lesser GNU Public License for more details.
(defparameter *last-trc* (get-internal-real-time))
(defun call-trc (stream s &rest os)
+ ;(break)
(if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*)
*trcdepth*)
(format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)
@@ -85,8 +97,6 @@ See the Lisp Lesser GNU Public License for more details.
(defmethod trcp :around (other)
(unless (call-next-method other)(break)))
-(export! trcp)
-
(defmethod trcp (other)
(eq other t))
@@ -99,8 +109,6 @@ See the Lisp Lesser GNU Public License for more details.
(defun trcdepth-decf ()
(format t "decrementing trc depth ~d" *trcdepth*)
(decf *trcdepth*))
-
-(export! wtrc eko-if)
(defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body )
`(let ((*trcdepth* (if *trcdepth*
@@ -121,11 +129,12 @@ See the Lisp Lesser GNU Public License for more details.
;------ eko --------------------------------------
-
(defmacro eko ((&rest trcargs) &rest body)
(let ((result (gensym)))
`(let ((,result ,@body))
- (trc ,(car trcargs) :=> ,result ,@(cdr trcargs))
+ ,(if (stringp (car trcargs))
+ `(trc ,(car trcargs) :=> ,result ,@(cdr trcargs))
+ `(trc ,(car trcargs) ,(cadr trcargs) :=> ,result ,@(cddr trcargs)))
,result)))
(defmacro ekx (ekx-id &rest body)
@@ -134,8 +143,6 @@ See the Lisp Lesser GNU Public License for more details.
(trc ,(string-downcase (symbol-name ekx-id)) :=> ,result)
,result)))
-(export! ekx)
-
(defmacro eko-if ((&rest trcargs) &rest body)
(let ((result (gensym)))
`(let ((,result ,@body))
@@ -148,4 +155,5 @@ See the Lisp Lesser GNU Public License for more details.
`(let ((,result (,@body)))
(when ,label
(trc ,label ,result))
- ,result)))
+ ,result)))
+
View
75 utils-kt/core.lisp
@@ -0,0 +1,75 @@
+#|
+
+ Utils-kt core
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+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 :utils-kt)
+
+(defmacro eval-now! (&body body)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ,@body))
+
+(defmacro export! (&rest symbols)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export ',symbols)))
+
+(defmacro define-constant (name value &optional docstring)
+ "Define a constant properly. If NAME is unbound, DEFCONSTANT
+it to VALUE. If it is already bound, and it is EQUAL to VALUE,
+reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again,
+resulting in implementation-specific behavior."
+ `(defconstant ,name
+ (if (not (boundp ',name))
+ ,value
+ (let ((value ,value))
+ (if (equal value (symbol-value ',name))
+ (symbol-value ',name)
+ value)))
+ ,@(when docstring (list docstring))))
+
+
+(export! exe-path exe-dll font-path)
+
+(defun exe-path ()
+ #+its-alive!
+ (excl:current-directory)
+ #-its-alive!
+ (excl:path-pathname (ide.base::project-file ide.base:*current-project*)))
+
+(defun font-path ()
+ (merge-pathnames
+ (make-pathname
+ :directory #+its-alive! (list :relative "font")
+ #-its-alive! (append (butlast (pathname-directory (exe-path)))
+ (list "TY Extender" "font")))
+ (exe-path)))
+
+#+test
+(list (exe-path)(font-path))
+
+(defmacro exe-dll (&optional filename)
+ (assert filename)
+ (concatenate 'string filename ".dll"))
+
+#+chya
+(defun exe-dll (&optional filename)
+ (merge-pathnames
+ (make-pathname :name filename :type "DLL"
+ :directory (append (butlast (pathname-directory (exe-path)))
+ (list "dll")))
+ (exe-path)))
+
+#+test
+(probe-file (exe-dll "openal32"))
View
3  utils-kt/datetime.lisp
@@ -197,5 +197,8 @@ See the Lisp Lesser GNU Public License for more details.
(defun hyphenated-time-string ()
(substitute #\- #\: (ymdhmsh)))
+
+#+test
+(hyphenated-time-string)
View
19 utils-kt/debug.lisp
@@ -27,6 +27,7 @@ See the Lisp Lesser GNU Public License for more details.
(defvar *stop* nil)
(defun utils-kt-reset ()
+ (clock-off :ukt-reset)
(setf *count* nil
*stop* nil
*dbg* nil)
@@ -121,3 +122,21 @@ See the Lisp Lesser GNU Public License for more details.
,form-measured)
,@postlude))
+(export! clock clock-0 clock-off)
+
+(defvar *clock*)
+
+(defun clock-off (key)
+ (when (boundp '*clock*)
+ (print (list :clock-off key))
+ (makunbound '*clock*)))
+
+(defun clock-0 (key &aux (now (get-internal-real-time)))
+ (setf *clock* (cons now now))
+ (print (list :clock-initialized-by key)))
+
+(defun clock (&rest keys &aux (now (get-internal-real-time)))
+ (when (boundp '*clock*)
+ (print (list* :clock (- now (cdr *clock*)) :tot (- now (car *clock*)) :at keys))
+ (setf (cdr *clock*) now)))
+
View
26 utils-kt/defpackage.lisp
@@ -17,6 +17,9 @@ See the Lisp Lesser GNU Public License for more details.
(in-package :cl-user)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf *features* (delete :its-alive! *features*)))
+
(defpackage :utils-kt
(:nicknames #:ukt)
(:use #:common-lisp
@@ -41,26 +44,3 @@ See the Lisp Lesser GNU Public License for more details.
#+(and mcl (not openmcl-partial-mop)) #:class-slots
))
-(in-package :utils-kt)
-
-(defmacro eval-now! (&body body)
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- ,@body))
-
-(defmacro export! (&rest symbols)
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (export ',symbols)))
-
-(defmacro define-constant (name value &optional docstring)
- "Define a constant properly. If NAME is unbound, DEFCONSTANT
-it to VALUE. If it is already bound, and it is EQUAL to VALUE,
-reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again,
-resulting in implementation-specific behavior."
- `(defconstant ,name
- (if (not (boundp ',name))
- ,value
- (let ((value ,value))
- (if (equal value (symbol-value ',name))
- (symbol-value ',name)
- value)))
- ,@(when docstring (list docstring))))
View
35 utils-kt/detritus.lisp
@@ -49,10 +49,7 @@ See the Lisp Lesser GNU Public License for more details.
(defun xor (c1 c2)
(if c1 (not c2) c2))
-(export! push-end collect collect-if)
-
-(defmacro push-end (item place )
- `(setf ,place (nconc ,place (list ,item))))
+(export! collect collect-if)
(defun collect (x list &key (key 'identity) (test 'eql))
(loop for i in list
@@ -60,10 +57,22 @@ See the Lisp Lesser GNU Public License for more details.
collect i))
(defun collect-if (test list)
- (loop for i in list
- when (funcall test i)
- collect i))
+ (remove-if-not test list))
+
+(defun test-setup ()
+ #-its-alive!
+ (ide.base::find-new-prompt-command
+ (cg.base::find-window :listener-frame)))
+
+#+test
+(test-setup)
+(defun test-prep ()
+ (test-setup))
+(defun test-init ()
+ (test-setup))
+
+(export! test-setup test-prep test-init)
;;; --- FIFO Queue -----------------------------
@@ -142,7 +151,8 @@ See the Lisp Lesser GNU Public License for more details.
do (bwhen (fname (pathname-name file))
(format t "~&~v,8t~a ~,40t~d" (1+ depth) fname lines))
summing lines)))
- (format t "~&~v,8t~a ~,50t~d" depth (pathname-directory path) directory-lines)
+ (unless (zerop directory-lines)
+ (format t "~&~v,8t~a ~,50t~d" depth (pathname-directory path) directory-lines))
directory-lines))
((find (pathname-type path) '("cl" "lisp" "c" "h" "java")
@@ -162,7 +172,14 @@ See the Lisp Lesser GNU Public License for more details.
#+(or)
(line-count (make-pathname
:device "c"
- :directory `(:absolute "0dev" "Algebra")) t)
+ :directory `(:absolute "0dev")))
+
+#+(or)
+(loop for d1 in '("cl-s3" "kpax" "puri-1.5.1" "s-base64" "s-http-client" "s-http-server" "s-sysdeps" "s-utils" "s-xml")
+ summing (line-count (make-pathname
+ :device "c"
+ :directory `(:absolute "1-devtools" ,d1))))
+
(export! tree-includes tree-traverse tree-intersect)
View
7 utils-kt/flow-control.lisp
@@ -59,6 +59,10 @@ See the Lisp Lesser GNU Public License for more details.
(defun tree-flatten (tree)
(list-flatten! (copy-tree tree)))
+(export! push-end)
+(defmacro push-end (item place )
+ `(setf ,place (nconc ,place (list ,item))))
+
(defun pair-off (list &optional (test 'eql))
(loop with pairs and copy = (copy-list list)
while (cdr copy)
@@ -184,8 +188,9 @@ See the Lisp Lesser GNU Public License for more details.
(export! without-repeating)
-
(let ((generators (make-hash-table :test 'equalp)))
+ (defun reset-without-repeating ()
+ (setf generators (make-hash-table :test 'equalp)))
(defun without-repeating (key all &optional (decent-interval (floor (length all) 2)))
(funcall (or (gethash key generators)
(setf (gethash key generators)
View
3  utils-kt/strings.lisp
@@ -90,6 +90,9 @@ See the Lisp Lesser GNU Public License for more details.
(defun left$ (s n)
(subseq s 0 (max (min n (length s)) 0)))
+(export! cc$)
+(defun cc$ (code) (string (code-char code)))
+
(defun mid$ (s offset length)
(let* ((slen (length s))
(start (min slen (max offset 0)))
View
17 utils-kt/utils-kt.lpr
@@ -1,16 +1,10 @@
-;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.1 [Windows] (Sep 29, 2007 20:23)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
-(defpackage :COMMON-LISP
- (:export #:list
- #:make-instance
- #:t
- #:nil
- #:quote))
-
(define-project :name :utils-kt
:modules (list (make-instance 'module :name "defpackage.lisp")
+ (make-instance 'module :name "core.lisp")
(make-instance 'module :name "debug.lisp")
(make-instance 'module :name "flow-control.lisp")
(make-instance 'module :name "detritus.lisp")
@@ -28,12 +22,13 @@
:runtime-modules nil
:splash-file-module (make-instance 'build-module :name "")
:icon-file-module (make-instance 'build-module :name "")
- :include-flags '(:local-name-info)
- :build-flags '(:allow-debug :purify)
+ :include-flags (list :local-name-info)
+ :build-flags (list :allow-debug :purify)
:autoload-warning t
:full-recompile-for-runtime-conditionalizations nil
+ :include-manifest-file-for-visual-styles t
:default-command-line-arguments "+cx +t \"Initializing\""
- :additional-build-lisp-image-arguments '(:read-init-files nil)
+ :additional-build-lisp-image-arguments (list :read-init-files nil)
:old-space-size 256000
:new-space-size 6144
:runtime-build-option :standard
Please sign in to comment.
Something went wrong with that request. Please try again.