[snow-cvs] r47 - in dependencies: . trunk trunk/cells trunk/cells/Use Cases trunk/cells/Use Cases/dow-jones trunk/cells/cells-test trunk/cells/doc trunk/cells/gui-geometry trunk/cells/tutorial trunk/cells/utils-kt trunk/cl-utilities-1.2.4 trunk/cl-utilities-1.2.4/doc trunk/named-readtables trunk/named-readtables/doc trunk/named-readtables/tests
Alessio Stalla
astalla at common-lisp.net
Tue Jan 26 20:20:07 UTC 2010
Author: astalla
Date: Tue Jan 26 15:20:07 2010
New Revision: 47
Log:
Importing lib folder to separate dependencies/ path.
Added:
dependencies/
dependencies/trunk/
dependencies/trunk/abcl.jar (contents, props changed)
dependencies/trunk/binding-2.0.6.jar (contents, props changed)
dependencies/trunk/cells/
dependencies/trunk/cells/README.txt (contents, props changed)
dependencies/trunk/cells/Use Cases/
dependencies/trunk/cells/Use Cases/dow-jones/
dependencies/trunk/cells/Use Cases/dow-jones/dow-jones.lpr (contents, props changed)
dependencies/trunk/cells/Use Cases/dow-jones/stock-exchange.lisp (contents, props changed)
dependencies/trunk/cells/cell-types.lisp (contents, props changed)
dependencies/trunk/cells/cells-manifesto.txt (contents, props changed)
dependencies/trunk/cells/cells-store.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/
dependencies/trunk/cells/cells-test/boiler-examples.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/build-sys.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/cells-test.asd (contents, props changed)
dependencies/trunk/cells/cells-test/cells-test.lpr (contents, props changed)
dependencies/trunk/cells/cells-test/deep-cells.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/df-interference.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/echo-setf.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/hello-world-q.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/hello-world.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/internal-combustion.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/lazy-propagation.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/output-setf.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/person.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/synapse-testing.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test-cycle.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test-cyclicity.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test-ephemeral.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test-family.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test-kid-slotting.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test-lazy.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test-synapse.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test.lpr (contents, props changed)
dependencies/trunk/cells/cells.asd (contents, props changed)
dependencies/trunk/cells/cells.lisp (contents, props changed)
dependencies/trunk/cells/cells.lpr (contents, props changed)
dependencies/trunk/cells/constructors.lisp (contents, props changed)
dependencies/trunk/cells/defmodel.lisp (contents, props changed)
dependencies/trunk/cells/defpackage.lisp (contents, props changed)
dependencies/trunk/cells/doc/
dependencies/trunk/cells/doc/01-Cell-basics.lisp (contents, props changed)
dependencies/trunk/cells/doc/cell-doc.lisp (contents, props changed)
dependencies/trunk/cells/doc/cells-overview.pdf (contents, props changed)
dependencies/trunk/cells/doc/hw.lisp (contents, props changed)
dependencies/trunk/cells/doc/motor-control.lisp (contents, props changed)
dependencies/trunk/cells/family-values.lisp (contents, props changed)
dependencies/trunk/cells/family.lisp (contents, props changed)
dependencies/trunk/cells/fm-utilities.lisp (contents, props changed)
dependencies/trunk/cells/gui-geometry/
dependencies/trunk/cells/gui-geometry/coordinate-xform.lisp (contents, props changed)
dependencies/trunk/cells/gui-geometry/defpackage.lisp (contents, props changed)
dependencies/trunk/cells/gui-geometry/geo-data-structures.lisp (contents, props changed)
dependencies/trunk/cells/gui-geometry/geo-family.lisp (contents, props changed)
dependencies/trunk/cells/gui-geometry/geo-macros.lisp (contents, props changed)
dependencies/trunk/cells/gui-geometry/geometer.lisp (contents, props changed)
dependencies/trunk/cells/gui-geometry/gui-geometry.asd (contents, props changed)
dependencies/trunk/cells/gui-geometry/gui-geometry.lpr (contents, props changed)
dependencies/trunk/cells/initialize.lisp (contents, props changed)
dependencies/trunk/cells/integrity.lisp (contents, props changed)
dependencies/trunk/cells/link.lisp (contents, props changed)
dependencies/trunk/cells/load.lisp (contents, props changed)
dependencies/trunk/cells/md-slot-value.lisp (contents, props changed)
dependencies/trunk/cells/md-utilities.lisp (contents, props changed)
dependencies/trunk/cells/model-object.lisp (contents, props changed)
dependencies/trunk/cells/propagate.lisp (contents, props changed)
dependencies/trunk/cells/slot-utilities.lisp (contents, props changed)
dependencies/trunk/cells/synapse-types.lisp (contents, props changed)
dependencies/trunk/cells/synapse.lisp (contents, props changed)
dependencies/trunk/cells/test-cc.lisp (contents, props changed)
dependencies/trunk/cells/test-cycle.lisp (contents, props changed)
dependencies/trunk/cells/test-ephemeral.lisp (contents, props changed)
dependencies/trunk/cells/test-propagation.lisp (contents, props changed)
dependencies/trunk/cells/test-synapse.lisp (contents, props changed)
dependencies/trunk/cells/test.lisp (contents, props changed)
dependencies/trunk/cells/trc-eko.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/
dependencies/trunk/cells/tutorial/01-lesson.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/01a-dataflow.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/01b-change-handling.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/01c-cascade.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/02-lesson.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/03-ephemeral.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/04-formula-once-then-input.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/test.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/tutorial.lpr (contents, props changed)
dependencies/trunk/cells/utils-kt/
dependencies/trunk/cells/utils-kt/core.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/datetime.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/debug.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/defpackage.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/detritus.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/flow-control.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/quad.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/split-sequence.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/strings.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/utils-kt.asd (contents, props changed)
dependencies/trunk/cells/utils-kt/utils-kt.lpr (contents, props changed)
dependencies/trunk/cells/variables.lisp (contents, props changed)
dependencies/trunk/cl-utilities-1.2.4/
dependencies/trunk/cl-utilities-1.2.4/README
dependencies/trunk/cl-utilities-1.2.4/cl-utilities.asd
dependencies/trunk/cl-utilities-1.2.4/collecting.lisp
dependencies/trunk/cl-utilities-1.2.4/compose.lisp
dependencies/trunk/cl-utilities-1.2.4/copy-array.lisp
dependencies/trunk/cl-utilities-1.2.4/doc/
dependencies/trunk/cl-utilities-1.2.4/doc/collecting.html
dependencies/trunk/cl-utilities-1.2.4/doc/compose.html
dependencies/trunk/cl-utilities-1.2.4/doc/copy-array.html
dependencies/trunk/cl-utilities-1.2.4/doc/expt-mod.html
dependencies/trunk/cl-utilities-1.2.4/doc/extremum.html
dependencies/trunk/cl-utilities-1.2.4/doc/index.html
dependencies/trunk/cl-utilities-1.2.4/doc/once-only.html
dependencies/trunk/cl-utilities-1.2.4/doc/read-delimited.html
dependencies/trunk/cl-utilities-1.2.4/doc/rotate-byte.html
dependencies/trunk/cl-utilities-1.2.4/doc/split-sequence.html
dependencies/trunk/cl-utilities-1.2.4/doc/style.css
dependencies/trunk/cl-utilities-1.2.4/doc/with-unique-names.html
dependencies/trunk/cl-utilities-1.2.4/expt-mod.lisp
dependencies/trunk/cl-utilities-1.2.4/extremum.lisp
dependencies/trunk/cl-utilities-1.2.4/once-only.lisp
dependencies/trunk/cl-utilities-1.2.4/package.lisp
dependencies/trunk/cl-utilities-1.2.4/package.sh (contents, props changed)
dependencies/trunk/cl-utilities-1.2.4/read-delimited.lisp
dependencies/trunk/cl-utilities-1.2.4/rotate-byte.lisp
dependencies/trunk/cl-utilities-1.2.4/split-sequence.lisp
dependencies/trunk/cl-utilities-1.2.4/test.lisp
dependencies/trunk/cl-utilities-1.2.4/with-unique-names.lisp
dependencies/trunk/commons-logging.jar (contents, props changed)
dependencies/trunk/miglayout-3.7.1.jar (contents, props changed)
dependencies/trunk/named-readtables/
dependencies/trunk/named-readtables/LICENSE
dependencies/trunk/named-readtables/cruft.lisp
dependencies/trunk/named-readtables/define-api.lisp
dependencies/trunk/named-readtables/doc/
dependencies/trunk/named-readtables/doc/named-readtables.html
dependencies/trunk/named-readtables/named-readtables.asd
dependencies/trunk/named-readtables/named-readtables.lisp
dependencies/trunk/named-readtables/package.lisp
dependencies/trunk/named-readtables/tests/
dependencies/trunk/named-readtables/tests/package.lisp
dependencies/trunk/named-readtables/tests/rt.lisp
dependencies/trunk/named-readtables/tests/tests.lisp
dependencies/trunk/named-readtables/utils.lisp
Added: dependencies/trunk/abcl.jar
==============================================================================
Binary file. No diff available.
Added: dependencies/trunk/binding-2.0.6.jar
==============================================================================
Binary file. No diff available.
Added: dependencies/trunk/cells/README.txt
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/README.txt Tue Jan 26 15:20:07 2010
@@ -0,0 +1,101 @@
+-*- text -*-
+
+***** About Cells *****
+
+(Installation instructions follow)
+
+Cells is a mature, stable extension to CLOS that allows you to create
+classes, the instances of which have slots whose values are determined
+by a formula. Think of the slots as cells in a spreadsheet (get it?),
+and you've got the right idea. You can use any arbitrary Common Lisp
+expression to specify the value of a cell. The Cells system takes care
+of tracking dependencies among cells, and propagating values. It is
+distributed under an MIT-style license.
+
+Documentation/support is in the form of:
+
+ the cells-devel mailing list (users and developers both welcome)
+ .\docs\01-cell-basics.lisp
+ .\docs\motor-control.lisp ;; actually Bill Clementson's blog entry
+ extensive examples in the Cells-test regression test suite
+ the companion Celtk module, which happens also to provide a substantial and
+ growing portable, native Common Lisp GUI.
+
+The above examples have all been tested against the current release of Cells.
+Now in .\doc is cells-overview.pdf. That is pretty rough and obsolete in re the
+code, but some of it might be enlightening.
+
+Cells is written in portable ANSI Common Lisp. It makes very
+light use of the introspective portions of the MOP, and contains a few
+workarounds for shortcomings in common implementations.
+
+Cells is known to currently work on the following Lisp implementations:
+
+ * Allegro
+ * SBCL
+ * CLISP
+ * LispWorks
+ * OpenMCL
+
+Partially supported are:
+
+ * CMUCL
+ * Corman Lisp
+ * MCL
+
+One of the Cells tests fails with CMUCL. This appears to be caused by
+a bug in CMUCL's CLOS implementation, but has not been investigated in
+great depth.
+
+Cells is believed to work with Corman CL, but has not been recently
+tested. In the past, MCL was supported, but a it does not currently
+pass the test suite. Ressurecting full support for any of these
+implementations should be easy.
+
+Porting Cells to an unsupported but ANSI-conforming Lisp
+implementation should be trivial: mostly a matter of determining the
+package where the MOP lives. In reality, however, you might have to
+find workarounds for bugs in ANSI compliance.
+
+***** Installation *****
+
+[ Cells follows the usual convention for asdf and asdf-installable
+ packages. If you know what that means, that's all you need to
+ know. ]
+
+Installation is trivial for asdf-install users:
+
+ (asdf-install:install :cells)
+
+Users without asdf-install will need to download the distribution from
+common-lisp.net. If your implementation does not come with ASDF,
+please complain to the implementor, then load the asdf.lisp file
+included in the Cells distribution.
+
+Unpack the distribution where you will.
+
+Unix users: If you do not already have an asdf central registry,
+create a directory calld asdf-registry under your home directory and
+push this onto asdf:*central-registry*. Create symlinks there to the
+cells.asd and cells-test.asd files in the distribution. Alternately,
+follow the instructions for Windows users.
+
+Windows and Classic Mac users: Push the directory where you unpacked
+the Cells distribution onto asdf:*central-registry*.
+
+You can now load Cells in the usual manner for asdf.
+
+SLIME:
+
+ ,load-system cells
+
+SBCL:
+
+ (require :cells)
+
+Other systems:
+
+ (asdf:oos 'asdf:load-op :cells)
+
+You may wish to run the test suite. To do so, use asdf to load the
+:cells-test system.
Added: dependencies/trunk/cells/Use Cases/dow-jones/dow-jones.lpr
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/Use Cases/dow-jones/dow-jones.lpr Tue Jan 26 15:20:07 2010
@@ -0,0 +1,81 @@
+;; -*- lisp-version: "7.0 [Windows] (Jun 10, 2005 13:34)"; cg: "1.54.2.17"; -*-
+
+(in-package :cg-user)
+
+(defpackage :CELLS)
+
+(define-project :name :dow-jones
+ :modules (list (make-instance 'module :name "stock-exchange.lisp"))
+ :projects (list (make-instance 'project-module :name
+ "..\\..\\cells"))
+ :libraries nil
+ :distributed-files nil
+ :internally-loaded-files nil
+ :project-package-name :cells
+ :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.icon :cg.icon-pixmap :cg.item-list
+ :cg.keyboard-shortcuts :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.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)
+ :autoload-warning t
+ :full-recompile-for-runtime-conditionalizations nil
+ :default-command-line-arguments "+M +t \"Console for Debugging\""
+ :additional-build-lisp-image-arguments '(:read-init-files nil)
+ :old-space-size 256000
+ :new-space-size 6144
+ :runtime-build-option :standard
+ :on-initialization 'cells::run-trading-day
+ :on-restart 'do-default-restart)
+
+;; End of Project Definition
Added: dependencies/trunk/cells/Use Cases/dow-jones/stock-exchange.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/Use Cases/dow-jones/stock-exchange.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,954 @@
+(in-package :cells)
+
+#|
+
+The deal is this: explanations of chunks of code appear /below/ them.
+
+Now here are Ron's functional requirements: process a stream of messages from an
+imagined source of financial data. Actually, Ron has an intermediate process
+reading a real source and producing a somewhat-digested stream in Lisp-friendly
+format. Sample:
+
+(:date 5123 :weekday 3)
+(:index ((AA 29.30 7.3894672) (AIG 53.30 7.3894672)(AXP 53.00 7.3894672)
+(BA 59.87 7.3894672) (C 46.80 7.3894672) (CAT 87.58 7.3894672) (DD 47.74 7.3894672)
+(DIS 26.25 7.3894672) (GE 36.10 7.3894672) (GM 27.77 7.3894672) (HD 36.75 7.3894672)
+(HON 35.30 7.3894672) (HPQ 21.00 7.3894672) (IBM 76.47 7.3894672)
+(INTC 23.75 7.3894672) (JNJ 68.73 7.3894672) (JPM 35.50 7.3894672) (KO 43.76 7.3894672)
+(MCD 29.80 7.3894672) (MMM 76.76 7.3894672) (MO 65.99 7.3894672) (MRK 34.42 7.3894672)
+(MSFT 25.36 7.3894672) (PFE 27.5 7.3894672) (PG 54.90 7.3894672) (SBC 23.8 7.3894672)
+(UTX 100.96 7.3894672) (VZ 36.75 7.3894672) (WMT 48.40 7.3894672) (XOM 56.50 7.3894672)))
+(:trade INTC 0.001932 :last 23.75)
+(:trade MSFT 0.001932 :last 25.36)
+(:trade INTC 0.011931 :last 23.75)
+(:trade MSFT 0.011931 :last 25.36)
+(:trade MSFT 0.041965 :last 25.32)
+(:trade UTX 0.067027 :last 101.39)
+...etc...
+
+Date messages encode date as (+ (* (- year 2000) 1000) julian-days). Weekday is dicey,
+so the tutorial deduces the Lisp weekday and stores that.
+
+Index messages define which tickers are in the index and their weights.
+Entries are: (ticker-symbol initial-price index-weight)
+
+Trade messages are (ticker-symbol ticker-minute :LAST price)
+Ticker-minute is time since open, in minutes. Negative indicates pre-open trading.
+
+To get the ball rolling, we just want to print out each trade as received, with the
+addition of an indicator as to which way the price moved: -1, 0, or 1 for down, unchanged, or up.
+
+For the index, we want to track the minute of the last trade affecting the index, the
+weighted index value, and the last move of each index entry.
+
+|#
+(defparameter *trc-trades* t)
+
+#+test
+(run-trading-day)
+
+(defun run-trading-day ()
+ (cell-reset)
+ (let ((*trc-trades* nil)
+ (t-day (make-be 'trading-day)))
+
+ ;; - always call CELLS-RESET when starting a test run
+ ;; - (make-be ...) -> (to-be (make-instance ...))
+ ;; - TO-BE jumpstarts a Cells instance into the flow. (FN to-be)
+ #+(or)
+ (with-open-file (t-data (make-pathname
+ :directory '(:absolute "0dev" "cells" "Use Cases" "dow-jones")
+ :name "trades0504" :type "txt"))
+ (with-metrics (nil t "run-trading-day")
+ (loop for message = (read t-data nil :eof)
+ until (eq message :eof)
+ do (count-it :dow-message)
+ (setf (message t-day) message)))
+ )
+
+ (with-open-file (t-data (make-pathname
+ :directory '(:absolute "0dev" "cells" "Use Cases" "dow-jones")
+ :name "stock-exchange" :type "lisp"))
+ (with-metrics (nil t "run-trading-day")
+ (loop with in-data = nil
+ do (if (not in-data)
+ (setf in-data (msg-start (read-line t-data nil :eof)))
+ (let ((message (read t-data nil :eof)))
+ (count-it :dow-message)
+ (if (eql (car message) :close)
+ (loop-finish)
+ (setf (message t-day) message)))))))
+
+ (trc "index value = " (value (car (indexes t-day))))))
+
+;; --- trading day ---------------------------------
+;;
+
+(defmodel trading-day ()
+ ((message :initarg :message :accessor message
+ :initform (c-in nil) ;; c-in -> c-input, how data enters a model (see FN c-input)
+ :cell :ephemeral) ;; handling transient phenomena in a steady-state paradigm (FN ephemeral)
+
+ (date :initarg :date :accessor date
+ :initform (c? (or .cache ;; advanced trick using prior value (see FN date/.cache)
+ (when (eql :date (car (^message)))
+ (destructuring-bind (&key date weekday)
+ (^message)
+ (declare (ignore weekday)) ;; derive from date
+ (encode-julian-date (+ 2000 (floor date 1000)) (mod date 1000)))))))
+
+ (weekday :initarg :weekday :accessor weekday
+ :initform (c? (when (^date)
+ (multiple-value-bind (second minute hour date month year day daylight-p zone)
+ (decode-universal-time (^date))
+ (declare (ignorable second minute hour date month year daylight-p zone))
+ day))))
+
+ ;; not much new here, but astute readers will wonder if this cell gets optimized away
+ ;; when (^date) on its second evaluation uses its .cache and gets optimized away.
+ ;;
+ ;; yes. Just checked to be sure.
+
+ (trade :cell :ephemeral :initarg :trade :accessor trade
+ :initform (c? (when (eql :trade (car (^message)))
+ (message-to-trade (^message)))))
+ ;;
+ ;; nothing new here, but note that again we use the :ephemeral option
+ ;;
+ (indexes :initarg :indexes :accessor indexes
+ :initform (c? (with-c-cache ('cons)
+ (when (eql :index (car (^message)))
+ (make-be 'index
+ :trading-day self
+ :index-def (second (^message)))))))
+ (tickers :cell nil :reader tickers :initform (make-hash-table :rehash-size 50))
+ ))
+
+
+(def-c-output trade ((self trading-day) trade) ;; FN def-c-output
+ (when trade ;; FN trade setf optimization
+ (count-it :raw-trades)
+ (push trade (trades (ensure-ticker self (trade-ticker-sym trade))))))
+
+(defun trading-day-ticker (day sym)
+ (gethash sym (tickers day)))
+
+(defun (setf trading-day-ticker) (ticker day sym)
+ (setf (gethash sym (tickers day)) ticker))
+
+(defun ensure-ticker (trading-day ticker-sym &optional price minute)
+ (or (trading-day-ticker trading-day ticker-sym)
+ (setf (trading-day-ticker trading-day ticker-sym)
+ (make-be 'ticker :ticker-sym ticker-sym
+ :trades (c-in (when price
+ (list (make-trade :ticker-sym ticker-sym
+ :minute minute :price price))))))))
+
+(defmodel ticker (model)
+ ((ticker-sym :cell nil :initarg :ticker-sym :reader ticker-sym)
+ (trades :initarg :trades :accessor trades :initform (c-in nil))
+ (last-trade-info :reader last-trade-info
+ :initform (c? (bwhen (trade (first (^trades)))
+ (bif (penult-trade (and (trade-price trade)
+ (find-if 'trade-price (rest (^trades)))))
+ (let* ((last (trade-price trade))
+ (penult (trade-price penult-trade))
+ (move (cond
+ ((< last penult) -1)
+ ((= last penult) 0)
+ (t 1))))
+ (values
+ (cons penult-trade move)
+ (if (zerop move) :no-propagate :propagate)))
+ (values (cons trade 0) :propagate)))))))
+
+(defun last-trade (ticker)
+ (car (last-trade-info ticker)))
+(defun last-move (ticker)
+ (cdr (last-trade-info ticker)))
+
+(defun ticker-price (ticker)
+ (bwhen (trade (last-trade ticker))
+ (trade-price trade)))
+
+(defun ticker-trade-minute (ticker)
+ (bwhen (trade (last-trade ticker))
+ (trade-minute trade)))
+
+(def-c-output trades ((self ticker)) ;; FN trades def-c-output
+ (when *trc-trades*
+ (loop for trade in (set-difference new-value old-value)
+ do (format t "~&at ~a min, ~a at ~a, change ~a"
+ (trade-minute trade) (ticker-sym self) (trade-price trade)
+ (or (last-move self) "")))))
+
+;; --- index ---------------------------------------------------
+
+(defmodel index ()
+ ((index-def :cell nil :initarg :index-def :initform nil :accessor index-def)
+ (trading-day :cell nil :initarg :trading-day :initform nil :accessor trading-day)
+ (ticker-weights :initarg :ticker-weights :accessor ticker-weights
+ :initform (c? (loop for (ticker-sym price weight) in (index-def self)
+ collecting (cons (ensure-ticker (trading-day self) ticker-sym price -60)
+ ;; whoa, a mid-rule to-be! (FN ticker-weights rule)
+ weight))))
+
+ (state :reader state
+ :initform (let ((moves (make-hash-table :size 50)))
+ (c-formula (:lazy nil) ;; do not re-compute on every trade (see FN lazy)
+ (count-it :index-state-calc)
+ (clrhash moves) ;; Re-use OK since fresh cons triggers dataflow (FN state rule)
+ (let ((minutes (loop for (ticker . nil) in (ticker-weights self)
+ maximizing (ticker-trade-minute ticker))))
+ (without-c-dependency ;; dependency on trade minute suffices (see FN without-c-dependency)
+ (loop for (ticker . weight) in (ticker-weights self)
+ summing (* weight (ticker-price ticker)) into value
+ do (setf (gethash (ticker-sym ticker) moves) (last-move ticker))
+ finally (return (list minutes value moves))))))))
+
+ (value :reader value :initform (c? (second (^state))))
+ ;;
+ ;; allows dependency on just value, which will not change on unchanged trades (FN value cell)
+ ))
+
+
+(defun index-minutes (index) (first (state index)))
+(defun index-moves (index) (third (state index)))
+(defun index-ticker-sym-move (index ticker-sym) (gethash ticker-sym (index-moves index)))
+(defun index-ticker-move (index ticker) (index-ticker-sym-move index (ticker-sym ticker)))
+
+(def-c-output value ((self index))
+ (when *trc-trades*
+ (trc "index time:" (index-minutes self) :value new-value :was old-value)))
+
+;;; --- trade ---------------------------------------------------------------------
+
+(defstruct trade minute ticker-sym price)
+
+(defun message-to-trade (message)
+ (destructuring-bind (ticker-sym ticker-min &key last) (rest message)
+ (make-trade
+ :ticker-sym ticker-sym
+ :minute ticker-min
+ :price last)))
+
+;;; --- utilities ---------------------------------------------------------
+
+(defun encode-julian-date (year julian)
+ (+ (encode-universal-time 0 0 0 1 1 year )
+ (* (1- julian) 86400))) ;; seconds in a day
+
+;; I am sorry, that is all there is to tell. So we have a mindless main loop and a few declarations
+;; and somehow we get all the functionality desired. [OK, granted, this is a pretty simple
+;; batch process which would not be too complicated in non-Cells form. In that regard, it
+;; is a good tutorial use case but does not show off Cells very much.] Anyway...
+;;
+;; It occurs to me that the above notes do not convey how the damn thing works. So let us walk
+;; thru a hand-execution of the above sample data.
+;;
+;; (make-be 'trading-day) -> (to-be (make-instance 'trading-day))
+;;
+;; Each ruled Cell gets evaluated. Each Cell slot -- constant, input, or ruled -- is output.
+;; So with trading-day:
+;;
+;; message is input, and has no associated output function
+;;
+;; date is evaluated:
+;;; (or .cache
+;;; (when (eql :date (car (^message)))
+;;; (destructuring-bind (&key date weekday)
+;;; (^message)
+;;; (declare (ignore weekday)) ;; derive from date
+;;; (encode-julian-date (+ 2000 (floor date 1000)) (mod date 1000)))))
+;;
+;; .cache is nil, but so is (message self). NIL is returned, there is no output.
+;; date now has a dependency on message.
+;;
+;; weekday is evaluated
+;;; (c? (when (^date)
+;;; (multiple-value-bind (second minute hour date month year day daylight-p zone)
+;;; (decode-universal-time (^date))
+;;; (declare (ignorable second minute hour date month year daylight-p zone))
+;;; day))))
+;; date is nil, so weekday is NIL but has a dependency on date. No output is defined.
+;;
+;; trade is evaluated
+;;; (c? (when (eql :trade (car (^message)))
+;;; (message-to-trade (^message)))))
+;; message is NIL, so NIL is returned. trade now has a dependency on message. The output
+;; method on trade is invoked, but has no interest in NIL new values.
+;;
+;; indexes is evaluated:
+;;; (with-c-cache ('cons)
+;;; (when (eql :index (car (^message)))
+;;; (make-be 'index
+;;; :trading-day self
+;;; :index-def (second (^message)))))))
+;; message is NIL, so NIL is returned, a dependency on message created. No output defined.
+;;
+;; (setf (message t-day) <the :date message>)
+;;
+;; Many rules are dispatched: date, trade, and indexes. Only date processes :date messages.
+;; it returns a converted date, and still has a dependency on message. Weekday has a dependency
+;; on date, so that rule gets dispatched. It returns a weekday calculated off the date, and
+;; keeps the dependency on that. Other rules return
+;; NIL, which is the same value they had before. Nothing else is done (and in this case, that
+;; would only have been to call the output method on trade.
+;;
+;; (setf (message t-day) <the :index message>)
+;;
+;; The date rule runs and returns its .cache without accessing any cell. The Cell internals
+;; optimize away the fact that date ever had a rule or any kind of cell. It sees weekday
+;; was a dependent on date and nothing else, so it optimizes that away, too. Slots end up
+;; with the last values calculated, and now look to other rules as if they were constant
+;; all along.
+;;
+;; The trade rule runs and comes up empty again. The indexes rule runs and adds a new
+;; index list to its current contents, which happens to be NIL.
+;;
+;;;; make-be is called on the index instance. Each slot gets processed in turn in a
+;;;; fashion similar to that for trading-day. When the ticker-weights rule runs, ticker
+;;;; instances for each ticker in the index are created and passed to TO-BE, in the
+;;;; function ensure-ticker. No dependencies are created since index-def is not a Cell,
+;;;; so the ticker-weights cell gets optimized away.
+;;;;
+;;;; as each ticker is created and processed by TO-BE:
+;;;;;;;
+;;;; the state rule is evaluated and computes an initial index state off the data
+;;;; provided in the index-def. state ends up with dependencies on each ticker in the
+;;;; index.
+;; [rest under construction]
+;;
+
+;;; =============================================================================
+;;; Footnotes
+;;; =============================================================================
+;
+;; --- FN to-be --------------------------------------
+;; TO-BE jumpstarts a Cells instance into the flow. Literally, as in
+;; the dataflow. It evaluates ruled slots to establish dependencies (those
+;; get established during evaluation) and in turn arrange for state change
+;; within the model to propagate to the instance's ruled Cells. It also
+;; DEF-C-OUTPUTs all cell slots so the outside world is consistent
+;; with the model state. More on def-c-output below.
+;
+;; --- FN c-input ------------------------------------
+;;
+;; c-in is short for c-input, which simply means imperative application code
+;; can SETF this slot. (Note that this is just the initform for this slot,
+;; which can be overridden by subclasses or at make-instance time, and if
+;; the override is not another C-IN or C-INPUT, then all bets are off. ie, The
+;; SETF ability depends on the type of Cell (if any) associated at run-time
+;; with the slot of an instance. It
+;; is not an attribute of the slot as with the :cell slot option discussed just below.
+;;
+;; Anyway, C-IN lets us make a lot of points about Cells.
+;;
+;; First, no model is
+;; an island; the dataflow has to start somewhere. Just as a VisiCalc spreadsheet
+;; has cells where you can type, say, different interest rates to see how that
+;; effects the rest of a financial model, a Cell-based application model needs
+;; some way to interface with the outside world, if only the mouse and keyboard
+;; of a GUI application.
+;;
+;; The way we do that is by having conventional application code feed (SETF) data into
+;; the dataflow model at what we call cell inputs. In a typical GUI app, this means
+;; having callbacks registered with the window manager. The callbacks then take their
+;; arguments (window events such as mouse-downs and key-presses) and setf that
+;; info to slots of a window or system instance modelling the window or operating
+;; system, slots mediated by c-input Cells.
+;;
+;; In this simple use case we have just one stream of external inputs (messages
+;; from some financial data service) being SETFed into one slot, the message
+;; slot of an instance of the trading-day class.
+;;
+;; Second, the Cells design enforces discipline. So in case you are
+;; wondering, no, if you do not bind a C-INPUT to a slot of an instance, you cannot
+;; SETF that slot from imperative code. (Aside: (SETF SLOT-VALUE) /is/ a back door
+;; allowing you to wreak havoc on your dataflow model if you so choose (but it will
+;; wreak havoc).)
+;;
+;; Third, you might wonder why slots meant as inputs cannot just have no Cell at all
+;; associated with them at run-time, and then have the Cell internals accept that
+;; as a SETF-able state. Well, it is a long story, but it turns out that a lot of
+;; Cells overhead can be avoided if we distinguish a slot whose value will never
+;; change from an input slot which will be SETF'ed. A simple example of a constant
+;; slot would be the bounding rectangle of a push button. Those values have to be
+;; Cells because in other graphical elements sharing the same superclass, the bounding
+;; rectangle changes. A good example is the win32-style scroll bar thumb, which changes
+;; size to reflect how much of the total file is visible. Anyway, it turns out that
+;; a significant performance boost comes from having Cells which happen to access
+;; a constant value not record a dependency on that value and, where a rule evaluation
+;; turns out not to access any non-constant other Cell slot, likewise convert the ruled
+;; slot into a constant slot. Sorry you asked?
+;;
+;; --- FN ephemeral -----------------------------------------------------------
+;;
+;; Whoa, here is an advanced topic. Ephemeral means "fleeting". Before getting into
+;; that, the other options for the :cell option are T and NIL. T is the default.
+;; NIL means you get a normal slot having nothing to do with Cells. Now about
+;; that :ephemeral option: Messages are
+;; like events: they happen, then they are no more. This is a problem for
+;; Cells, which like a VisiCalc spreadsheet model (say, your household budget)
+;; is all about steady-state occasionally perturbed by inputs. That is vague.
+;; Here is a concrete example: suppose you have some game where the user has
+;; to press a key when two randomly moving shapes overlap. You will have a hit rule
+;; that says (abbreviated somewhat):
+;;
+;; (and (eql (event *sys*) :keypress) (shapes-overlap-p *sys*))
+;;
+;; OK, the key is pressed but the shapes do not overlap. No cigar. Now a few
+;; seconds later the shapes do overlap. The key is not being pressed, but the
+;; EVENT slot of the *sys* instance (modelling the computer system) still
+;; says :keypress. bad news. Obviously we need to process an event and then
+;; clear the value before processing any other model input. Now perhaps we could
+;; simply have imperative code which says:
+;;
+;; (setf (event *sys*) :keypress)
+;; (setf (event *sys*) nil)
+;;
+;; But that is different. That suggests an application semantic in which the
+;; EVENT slot changes from :keypress to NIL. It will trigger all the usual
+;; dataflow, to see if the model should react. But in fact what we /really/
+;; need is /not/ to clear the EVENT slot. What we really need is
+;; ephemeral SETF behavior from a mechanism designed for steady-state.
+;; We need the EVENT slot to take on a value just long enough to perturb our
+;; model and then cease to be without fanfare.
+;;
+;; So we extend the Cells model with the :ephemeral option on a slot, and have
+;; Cell internals watch out for that and silently clear the slot once a value
+;; has been propagated to other Cells and output (again, outputs
+;; are discussed below.)
+;;
+;; A final newbie note: watch the bouncing options. Ephemerality is a slot option,
+;; not something one tailors to the instance. Think about it. Think about the
+;; slot names. "message", "event". We want to get ephemeral behavior for these
+;; slots no matter what cell (input or ruled) we choose to associate with them.
+;; So it is more convenient and reliable to endow the slot itself with ephemerality.
+;; in other cases we see different instances enjoying different Cell-ish qualities
+;; for the same slot, sometimes constant, sometimes computed, sometimes being
+;; SETFed by imperative code outside the dataflow model. These variations are
+;; then found in the type of runtime Cell associated with the Cell slot.
+;;
+;; --- FN date/.cache --------------------------------------------------
+;;
+;;
+;; There is a lot going on here, too, including some premature optimization.
+;;
+;; First of all, .cache is just a local variable, bound by the expansion
+;; of the C? macro to the latest value calculated for this rule. It starts out as NIL, so
+;; the rule next reads the message slot of the same trading-day instance. How so?
+;;
+;; ^message is a macro written by the defmodel macro. It expands simply to:
+;;
+;; (message self)
+;;
+;; It used to expand to more, including vital Cell plumbing. Now I keep it around just
+;; because I love that self-documenting quality. And yes, I have adopted the
+;; Smalltalk "self" convention over the C++ "this" convention. There is no need
+;; to use these (^macros), just code (<slot-name> self) and you will establish a
+;; dependency on the message slot. What does dependency mean?
+;;
+;; Simply that the next time the message slot changes (the default test between old and
+;; new values is EQL, but can be overridden), the Cells engine will immediately kick
+;; the DATE rule to see if it wants to compute a different value.
+;;
+;; A very important point is that dependencies are established automatically simply
+;; by invoking the reader or accessor associated with a slot, and that this happens
+;; dynamically at run-time, not by inspection of code. A second point is that the
+;; dependency is established even if the read takes place in a called function.
+;;
+;; There is a backdoor. No dependencies are established in code wrapped by
+;; the macro WITHOUT-C-DEPENDENCY.
+;;
+;; Another important point is that dependencies are re-decided completely each time
+;; a rule is invoked. So this particular rule is an oddball: it will produce only one value, when a :date
+;; message is received
+;; and teh first non-NIL value is returned. On the next message (of any kind) .cache will be
+;; non-NIL and the rule will simply return that value.
+;; During this last evaluation the cell will not access, hence no longer
+;; depend on, the message slot or any other slot and it will get optimized away. This
+;; improves performance, since the message slot no longer bothers propagating to
+;; the date slot and Cell internals no longer have to invoke the rule. Otherwise, every
+;; new message for the entire day (none of which would be :date messages) would kick
+;; off this rule.
+;;
+;; --- FN with-c-cache ------------------------------------
+;;
+;; I am actually doing something new here. The idea is that again we deviate
+;; slightly from the spreadsheet paradigm and want to accumulate data
+;; from a stream of ephemeral values. Normally we calculate a slot value in
+;; its entirety from data at hand, even if only ephemerally. Here we want
+;; to add a newly computed result to a list of prior such results.
+;;
+;; with-c-cache will accept any two-argument function, and when the enclosed
+;; form returns a non-nil value, pass that and the .cache to the specified
+;; function.
+;;
+;; --- FN def-c-output --------------------------------------------
+;;
+;; Above is another optimization, and the long-awaited discussion of Cell
+;; output.
+;;
+;; Output reinforces the "no model is an island" theme. We create
+;; models to obtain interesting outputs from inputs, where the model
+;; provides the interest. For a RoboCup player simulation, the inputs are
+;; sensory information about the game, provided in a stream from a server
+;; application managing multiple client players and coaches. The outputs are
+;; messages to the server indicating player choices about turning, running,
+;; and kicking. In between, the game play model is supposed to compute
+;; actions producing more or less capable soccer play.
+;;
+;; --- FN trade setf optimization ---------------------------------------
+;
+;; But this is strange "output". It actually changes internal model state.
+;; It is no output at all, just feeding dataflow back into a different
+;; model input. Whassup?
+;;
+;; Like I said, it is an optimization. A ticker instance could have a
+;; rule which watched the message stream looking for trades on that ticker,
+;; but then every ticker would be watching the message stream.
+;;
+;; Instead, we simply leverage an "output" method to procedurally decide which
+;; ticker has been traded and directly add the trade to that ticker's list
+;; of trades.
+;;
+;; --- FN trades def-c-output --------------------------------------
+;;
+;; Now the above is a proper output. Merely a print trace to standard output, but
+;; that happens to be all the output we want just now. In a real trading application,
+;; there probably would not be an output on this slot. Some gui widget might "output"
+;; by telling the OS to redraw it, or some trader instance might decide to output
+;; a buy order to an exchange, but that is about it.
+;;
+;; --- FN ticker-weights rule --------------------------------------
+;;
+;; A curiosity here is that ensure-ticker will often be making and to-be-ing new model
+;; instances while this rule is running. No problem, though it would be possible to
+;; get into trouble if such destructive (well, constructive) operations triggered
+;; dataflow back to this same rule. Here we are safe; it does not. In fact...
+;;
+;; This rule runs once and then gets optimized away, because in this simple case
+;; index-def is a constant, not even a cell. Should we someday want to handle
+;; changes to an index during a trading-day, this would have to change.
+;;
+;; --- FN lazy ------------------------------------------------------
+;;
+;; Lazy ruled cells do not get calculated until someone asks their value,
+;; and once they are evaluated and dependencies have been established,
+;; they merely will be flagged "obsolete" should any of those dependencies
+;; change in value.
+;;
+;; --- FN state rule ------------------------------------------------
+;;
+;; c? ends up wrapping its body in a lambda form which becomes the rule for this
+;; slot, and here that lambda form will close over the MOVES hash-table. Neat, eh?
+;; What is going on is that we do not anticipate in the application design that
+;; any cell will depend in isolation on the move of one ticker in the index. So
+;; we can allocate just one hashtable at make-instance time and reuse that each
+;; time the rule gets evaluated. Cells depending on the state Cell will know
+;; when that aggregate value gets recomputed because the finally clause conses
+;; up a new list each time.
+;;
+;; --- FN without-c-dependency -------------------------------------
+;;
+;; Our application knowledge tells us the dependency on ticker minute will suffice
+;; to keep index state up to date, so we save a lot of internal cells overhead
+;; by taking a chance and disabling dependency creation within the wrapper
+;; with-c-output. (The danger is that someone later adds a desired dependency reference
+;; to the rule without noticing the wrapper.)
+;;
+;; --- FN value Cell --------------------------------------------------
+;;
+;; Weird, right? Well, we noticed that many trades came thru at the same price
+;; sequentially. The rule above for STATE gets kicked off on each trade, and the
+;; index gets recomputed. Because it is an aggregate, we get a new list for state
+;; even if the trade was at an unchanged priced and the index value does not change.
+;;
+;; Now suppose there was some BUY! rule which cared only about the index value, and not
+;; the latest minute traded of that value, which /would/ change if a new trade at
+;; an unchanged price were received. Because a new list gets consed up (never mind the
+;; new trade minute), The BUY! rule would get kicked off because of the new list in the
+;; the STATE slot. Not even overriding the default EQL test with EQUAL would work,
+;; because the trade minute would have changed.
+;;
+;; What to do? The above. Let VALUE get recalculated unnecessarily and return unchanged,
+;; then code the BUY! rule to use VALUE. VALUE will get kicked off, but not BUY!, which
+;; would likely be computationally intense.
+;;
+
+#| TRADEDATA
+(:date 5123 :weekday 3)
+(:index ((AA 29.30 7.3894672) (AIG 53.30 7.3894672)(AXP 53.00 7.3894672)
+(BA 59.87 7.3894672) (C 46.80 7.3894672) (CAT 87.58 7.3894672) (DD 47.74 7.3894672)
+(DIS 26.25 7.3894672) (GE 36.10 7.3894672) (GM 27.77 7.3894672) (HD 36.75 7.3894672)
+(HON 35.30 7.3894672) (HPQ 21.00 7.3894672) (IBM 76.47 7.3894672)
+(INTC 23.75 7.3894672) (JNJ 68.73 7.3894672) (JPM 35.50 7.3894672) (KO 43.76 7.3894672)
+(MCD 29.80 7.3894672) (MMM 76.76 7.3894672) (MO 65.99 7.3894672) (MRK 34.42 7.3894672)
+(MSFT 25.36 7.3894672) (PFE 27.5 7.3894672) (PG 54.90 7.3894672) (SBC 23.8 7.3894672)
+(UTX 100.96 7.3894672) (VZ 36.75 7.3894672) (WMT 48.40 7.3894672) (XOM 56.50 7.3894672)))
+(:trade INTC 0.001932 :last 23.75)
+(:trade MSFT 0.001932 :last 25.36)
+(:trade INTC 0.011931 :last 23.75)
+(:trade MSFT 0.011931 :last 25.36)
+(:trade MSFT 0.041965 :last 25.32)
+(:trade UTX 0.067027 :last 101.39)
+(:trade INTC 0.067062 :last 23.82)
+(:trade MSFT 0.070397 :last 25.37)
+(:trade INTC 0.070397 :last 23.82)
+(:trade MSFT 0.074167 :last 25.32)
+(:trade INTC 0.081800 :last 23.83)
+(:trade MSFT 0.097178 :last 25.33)
+(:trade MSFT 0.106488 :last 25.32)
+(:trade INTC 0.110410 :last 23.82)
+(:trade INTC 0.124263 :last 23.83)
+(:trade MSFT 0.130411 :last 25.33)
+(:trade INTC 0.143792 :last 23.81)
+(:trade MSFT 0.143792 :last 25.33)
+(:trade DIS 0.150441 :last 26.25)
+(:trade INTC 0.160480 :last 23.82)
+(:trade MSFT 0.160480 :last 25.33)
+(:trade HPQ 0.166767 :last 21.00)
+(:trade INTC 0.178832 :last 23.82)
+(:trade MSFT 0.183710 :last 25.33)
+(:trade DIS 0.187167 :last 26.25)
+(:trade AIG 0.193117 :last 53.60)
+(:trade INTC 0.196399 :last 23.81)
+(:trade PFE 0.200523 :last 27.51)
+(:trade MSFT 0.200523 :last 25.33)
+(:trade GE 0.202185 :last 36.11)
+(:trade MSFT 0.207199 :last 25.37)
+(:trade BA 0.209810 :last 59.75)
+(:trade INTC 0.210524 :last 23.83)
+(:trade MSFT 0.230556 :last 25.37)
+(:trade INTC 0.230556 :last 23.83)
+(:trade BA 0.234812 :last 59.76)
+(:trade MSFT 0.240580 :last 25.37)
+(:trade INTC 0.247233 :last 23.83)
+(:trade MSFT 0.256892 :last 25.37)
+(:trade UTX 0.257729 :last 101.33)
+(:trade GE 0.261942 :last 36.11)
+(:trade AIG 0.267072 :last 53.60)
+(:trade MSFT 0.272956 :last 25.36)
+(:trade INTC 0.275617 :last 23.83)
+(:trade WMT 0.280660 :last 48.40)
+(:trade SBC 0.284975 :last 23.78)
+(:trade GE 0.289229 :last 36.10)
+(:trade MSFT 0.292285 :last 25.35)
+(:trade DIS 0.295646 :last 26.30)
+(:trade HPQ 0.303630 :last 21.04)
+(:trade IBM 0.305629 :last 76.60)
+(:trade INTC 0.307321 :last 23.81)
+(:trade INTC 0.310671 :last 23.81)
+(:trade SBC 0.316331 :last 23.76)
+(:trade AIG 0.322292 :last 53.60)
+(:trade MSFT 0.324057 :last 25.36)
+(:trade MCD 0.324057 :last 29.79)
+(:trade UTX 0.325694 :last 101.15)
+(:trade INTC 0.327348 :last 23.81)
+(:trade IBM 0.336878 :last 76.60)
+(:trade MSFT 0.342414 :last 25.37)
+(:trade MSFT 0.345710 :last 25.37)
+(:trade HD 0.346983 :last 36.82)
+(:trade BA 0.347295 :last 59.80)
+(:trade MCD 0.360765 :last 29.80)
+(:trade HPQ 0.364067 :last 21.03)
+(:trade MSFT 0.364067 :last 25.37)
+(:trade SBC 0.367409 :last 23.79)
+(:trade MSFT 0.392928 :last 25.36)
+(:trade AIG 0.407453 :last 53.55)
+(:trade HPQ 0.407533 :last 21.03)
+(:trade SBC 0.407533 :last 23.79)
+(:trade MSFT 0.407533 :last 25.36)
+(:trade INTC 0.407533 :last 23.82)
+(:trade HPQ 0.407533 :last 21.03)
+(:trade HD 0.407545 :last 36.84)
+(:trade BA 0.413185 :last 59.80)
+(:trade INTC 0.414117 :last 23.81)
+(:trade PFE 0.420796 :last 27.51)
+(:trade DIS 0.424120 :last 26.30)
+(:trade AIG 0.424654 :last 53.58)
+(:trade INTC 0.427471 :last 23.81)
+(:trade XOM 0.429865 :last 56.85)
+(:trade IBM 0.431927 :last 76.65)
+(:trade HPQ 0.432407 :last 21.04)
+(:trade HD 0.432507 :last 36.84)
+(:trade MCD 0.439207 :last 29.80)
+(:trade MSFT 0.442518 :last 25.36)
+(:trade DIS 0.442518 :last 26.30)
+(:trade MSFT 0.453747 :last 25.36)
+(:trade PFE 0.458821 :last 27.52)
+(:trade IBM 0.459026 :last 76.66)
+(:trade HON 0.467342 :last 35.36)
+(:trade XOM 0.469083 :last 56.88)
+(:trade INTC 0.470871 :last 23.80)
+(:trade SBC 0.476712 :last 23.79)
+(:trade BA 0.476730 :last 59.80)
+(:trade MCD 0.479248 :last 29.80)
+(:trade HPQ 0.479248 :last 21.03)
+(:trade AIG 0.480883 :last 53.57)
+(:trade MSFT 0.482567 :last 25.36)
+(:trade INTC 0.482567 :last 23.80)
+(:trade IBM 0.484223 :last 76.73)
+(:trade MSFT 0.494243 :last 25.36)
+(:trade AIG 0.497551 :last 53.57)
+(:trade PFE 0.497569 :last 27.53)
+(:trade INTC 0.504245 :last 23.80)
+(:trade HD 0.504660 :last 36.84)
+(:trade IBM 0.504849 :last 76.73)
+(:trade GM 0.507621 :last 30.53)
+(:trade SBC 0.511484 :last 23.79)
+(:trade HPQ 0.514265 :last 21.04)
+(:trade HD 0.514798 :last 36.85)
+(:trade MSFT 0.517601 :last 25.32)
+(:trade WMT 0.524286 :last 48.46)
+(:trade IBM 0.524286 :last 76.74)
+(:trade INTC 0.529220 :last 23.80)
+(:trade HPQ 0.536813 :last 21.04)
+(:trade PG 0.537627 :last 54.91)
+(:trade PFE 0.540979 :last 27.54)
+(:trade INTC 0.544290 :last 23.80)
+(:trade PG 0.547549 :last 54.91)
+(:trade XOM 0.547624 :last 56.85)
+(:trade HON 0.547687 :last 35.40)
+(:trade UTX 0.550986 :last 101.33)
+(:trade HD 0.555694 :last 36.85)
+(:trade MSFT 0.560792 :last 25.35)
+(:trade INTC 0.564337 :last 23.80)
+(:trade XOM 0.566779 :last 56.85)
+(:trade BA 0.567359 :last 59.81)
+(:trade HON 0.581023 :last 35.41)
+(:trade INTC 0.589796 :last 23.80)
+(:trade BA 0.596050 :last 59.80)
+(:trade CAT 0.612134 :last 87.83)
+(:trade WMT 0.618386 :last 48.44)
+(:trade INTC 0.620474 :last 23.80)
+(:trade MCD 0.624417 :last 29.80)
+(:trade MSFT 0.627748 :last 25.35)
+(:trade BA 0.630881 :last 59.83)
+(:trade AIG 0.634410 :last 53.56)
+(:trade MCD 0.637785 :last 29.79)
+(:trade HON 0.637785 :last 35.40)
+(:trade INTC 0.649577 :last 23.79)
+(:trade BA 0.655889 :last 59.85)
+(:trade HD 0.662287 :last 36.83)
+(:trade AIG 0.669431 :last 53.53)
+(:trade HON 0.671133 :last 35.44)
+(:trade MCD 0.674457 :last 29.79)
+(:trade MO 0.683443 :last 66.20)
+(:trade INTC 0.687668 :last 23.79)
+(:trade MSFT 0.691181 :last 25.35)
+(:trade PFE 0.694477 :last 27.54)
+(:trade MSFT 0.720936 :last 25.35)
+(:trade GM 0.726237 :last 30.50)
+(:trade WMT 0.730056 :last 48.40)
+(:trade IBM 0.740544 :last 76.74)
+(:trade PG 0.744569 :last 54.91)
+(:trade HON 0.752103 :last 35.46)
+(:trade CAT 0.753014 :last 87.85)
+(:trade MO 0.763918 :last 66.20)
+(:trade MSFT 0.764592 :last 25.35)
+(:trade HON 0.771289 :last 35.46)
+(:trade BA 0.772935 :last 59.75)
+(:trade JPM 0.773229 :last 35.51)
+(:trade MSFT 0.774612 :last 25.35)
+(:trade PG 0.776267 :last 54.91)
+(:trade AIG 0.781168 :last 53.54)
+(:trade HD 0.782946 :last 36.87)
+(:trade CAT 0.784614 :last 87.85)
+(:trade XOM 0.786285 :last 56.88)
+(:trade MSFT 0.792950 :last 25.36)
+(:trade UTX 0.794689 :last 101.40)
+(:trade INTC 0.797969 :last 23.78)
+(:trade IBM 0.801301 :last 76.74)
+(:trade HD 0.809652 :last 36.87)
+(:trade JPM 0.809652 :last 35.51)
+(:trade MSFT 0.811489 :last 25.37)
+(:trade MO 0.812994 :last 66.20)
+(:trade IBM 0.816563 :last 76.75)
+(:trade MCD 0.828046 :last 29.77)
+(:trade UTX 0.829055 :last 101.37)
+(:trade MSFT 0.833420 :last 25.36)
+(:trade GM 0.837650 :last 30.50)
+(:trade IBM 0.838004 :last 76.75)
+(:trade HON 0.838531 :last 35.47)
+(:trade XOM 0.841372 :last 56.88)
+(:trade MCD 0.841894 :last 29.78)
+(:trade KO 0.853202 :last 43.98)
+(:trade UTX 0.858235 :last 101.38)
+(:trade INTC 0.864331 :last 23.82)
+(:trade PFE 0.869104 :last 27.55)
+(:trade HON 0.873063 :last 35.48)
+(:trade IBM 0.873095 :last 76.77)
+(:trade HD 0.873132 :last 36.87)
+(:trade XOM 0.884796 :last 56.86)
+(:trade UTX 0.884820 :last 101.38)
+(:trade HON 0.888886 :last 35.48)
+(:trade INTC 0.891420 :last 23.81)
+(:trade CAT 0.895715 :last 87.86)
+(:trade MO 0.898111 :last nil) ;; 66.19)
+(:trade XOM 0.898111 :last 56.87)
+(:trade IBM 0.899775 :last 76.78)
+(:trade BA 0.899775 :last 59.83)
+(:trade MSFT 0.901469 :last 25.38)
+(:trade HD 0.906673 :last 36.86)
+(:trade HPQ 0.908113 :last 21.03)
+(:trade CAT 0.916467 :last 87.85)
+(:trade BA 0.916467 :last 59.83)
+(:trade MSFT 0.918773 :last 25.38)
+(:trade PFE 0.926271 :last 27.57)
+(:trade MO 0.926288 :last 66.18)
+(:trade WMT 0.929791 :last 48.40)
+(:trade KO 0.932333 :last 43.98)
+(:trade JNJ 0.933224 :last 68.15)
+(:trade PG 0.936516 :last 54.91)
+(:trade INTC 0.938989 :last 23.81)
+(:trade IBM 0.942596 :last 76.78)
+(:trade XOM 0.944052 :last 56.89)
+(:trade INTC 0.944885 :last 23.81)
+(:trade BA 0.946486 :last 59.85)
+(:trade IBM 0.958178 :last 76.78)
+(:trade INTC 0.959853 :last 23.81)
+(:trade JPM 0.959897 :last 35.50)
+(:trade WMT 0.961498 :last 48.40)
+(:trade MCD 0.963195 :last 29.77)
+(:trade HPQ 0.966525 :last 21.03)
+(:trade AIG 0.968663 :last 53.54)
+(:trade XOM 0.978210 :last 56.89)
+(:trade AIG 0.979896 :last 53.55)
+(:trade CAT 0.979896 :last 87.85)
+(:trade MCD 0.984732 :last 29.77)
+(:trade PG 0.985307 :last 54.90)
+(:trade WMT 0.995716 :last 48.41)
+(:trade MSFT 1.005256 :last 25.38)
+(:trade PFE 1.005256 :last 27.55)
+(:trade JPM 1.008448 :last 35.48)
+(:trade CAT 1.011343 :last 87.86)
+(:trade XOM 1.011825 :last 56.88)
+(:trade INTC 1.012667 :last 23.79)
+(:trade JNJ 1.018655 :last 68.15)
+(:trade KO 1.021589 :last 43.99)
+(:trade INTC 1.026597 :last 23.78)
+(:trade HD 1.029577 :last 36.85)
+(:trade MSFT 1.029936 :last 25.39)
+(:trade JPM 1.033267 :last 35.49)
+(:trade C 1.064996 :last 46.80)
+(:trade CAT 1.065946 :last 87.85)
+(:trade MCD 1.066687 :last 29.75)
+(:trade MRK 1.066687 :last 34.33)
+(:trade PFE 1.066687 :last 27.55)
+(:trade INTC 1.066687 :last 23.79)
+(:trade INTC 1.066687 :last 23.79)
+(:trade XOM 1.068360 :last 56.88)
+(:trade JPM 1.068360 :last 35.49)
+(:trade XOM 1.068360 :last 56.89)
+(:trade KO 1.068360 :last 43.99)
+(:trade MRK 1.070274 :last 34.34)
+(:trade HON 1.073312 :last 35.49)
+(:trade PFE 1.080025 :last 27.55)
+(:trade MCD 1.080025 :last 29.75)
+(:trade INTC 1.080025 :last 23.79)
+(:trade AIG 1.083337 :last 53.55)
+(:trade GM 1.083420 :last 30.55)
+(:trade XOM 1.086739 :last 56.89)
+(:trade HON 1.093425 :last 35.49)
+(:trade HPQ 1.093425 :last 21.03)
+(:trade INTC 1.093425 :last 23.79)
+(:trade MSFT 1.093425 :last 25.37)
+(:trade JPM 1.098339 :last 35.49)
+(:trade IBM 1.099113 :last 76.86)
+(:trade XOM 1.104257 :last 56.89)
+(:trade MCD 1.104268 :last 29.74)
+(:trade GE 1.108379 :last 36.14)
+(:trade MSFT 1.108408 :last 25.40)
+(:trade XOM 1.115052 :last 56.89)
+(:trade JPM 1.118397 :last 35.50)
+(:trade GM 1.118397 :last 30.55)
+(:trade C 1.125426 :last 46.78)
+(:trade MCD 1.132390 :last 29.74)
+(:trade WMT 1.133494 :last 48.40)
+(:trade MRK 1.135099 :last 34.33)
+(:trade MSFT 1.135099 :last 25.39)
+(:trade INTC 1.135099 :last 23.78)
+(:trade INTC 1.146096 :last 23.79)
+(:trade KO 1.146108 :last 43.99)
+(:trade WMT 1.155346 :last 48.41)
+(:trade PG 1.158447 :last 54.90)
+(:trade WMT 1.162645 :last 48.41)
+(:trade HON 1.162660 :last 35.52)
+(:trade KO 1.162672 :last 43.98)
+(:trade JNJ 1.166783 :last 68.20)
+(:trade DIS 1.166815 :last 26.34)
+(:trade HD 1.166856 :last 36.90)
+(:trade MCD 1.171129 :last 29.74)
+(:trade INTC 1.175130 :last 23.79)
+(:trade JPM 1.178485 :last 35.50)
+(:trade KO 1.178485 :last 43.98)
+(:trade MSFT 1.184447 :last 25.39)
+(:trade AIG 1.191811 :last 53.56)
+(:trade WMT 1.195138 :last 48.41)
+(:trade MSFT 1.199050 :last 25.39)
+(:trade MO 1.201440 :last 66.18)
+(:trade INTC 1.201841 :last 23.80)
+(:trade DIS 1.201841 :last 26.34)
+(:trade JNJ 1.202292 :last 68.20)
+(:trade C 1.205172 :last 46.79)
+(:trade KO 1.205172 :last 43.98)
+(:trade WMT 1.209557 :last 48.40)
+(:trade INTC 1.209927 :last 23.79)
+(:trade VZ 1.209962 :last 34.75)
+(:trade MSFT 1.213558 :last 25.37)
+(:trade C 1.220169 :last 46.79)
+(:trade DIS 1.220225 :last 26.34)
+(:trade PFE 1.220225 :last 27.55)
+(:trade JNJ 1.220921 :last 68.20)
+(:trade MMM 1.223614 :last 76.70)
+(:trade INTC 1.226875 :last 23.79)
+(:trade DIS 1.230230 :last 26.34)
+(:trade HPQ 1.230230 :last 21.03)
+(:trade HON 1.230230 :last 35.52)
+(:trade PFE 1.230230 :last 27.56)
+(:trade SBC 1.230230 :last 23.78)
+(:trade C 1.236915 :last 46.79)
+(:trade MSFT 1.240577 :last 25.40)
+(:trade DIS 1.243960 :last 26.34)
+(:trade SBC 1.250258 :last 23.78)
+(:trade MCD 1.250258 :last 29.74)
+(:trade MSFT 1.250258 :last 25.40)
+(:trade INTC 1.253588 :last 23.79)
+(:trade HON 1.253588 :last 35.53)
+(:trade MCD 1.257704 :last 29.74)
+(:trade MSFT 1.262803 :last 25.37)
+(:trade KO 1.271926 :last 43.99)
+(:trade JPM 1.271926 :last 35.51)
+(:trade VZ 1.276339 :last 34.75)
+(:trade MSFT 1.280283 :last 25.40)
+(:trade HPQ 1.280283 :last 21.03)
+(:trade DIS 1.288624 :last 26.34)
+(:trade GE 1.288664 :last 36.14)
+(:trade JPM 1.288664 :last 35.51)
+(:trade AIG 1.290300 :last 53.59)
+(:trade CAT 1.290300 :last 87.86)
+(:trade IBM 1.290300 :last 76.85)
+(:trade SBC 1.291940 :last 23.77)
+(:trade XOM 1.301948 :last 56.88)
+(:trade DIS 1.303625 :last 26.34)
+(:trade AIG 1.304047 :last 53.60)
+(:trade KO 1.305316 :last 43.99)
+(:trade JPM 1.305316 :last 35.51)
+(:trade C 1.305316 :last 46.79)
+(:trade KO 1.314761 :last 43.99)
+(:trade DIS 1.316972 :last 26.35)
+(:trade HON 1.316972 :last 35.54)
+(:trade CAT 1.317022 :last 87.86)
+(:trade IBM 1.317022 :last 76.85)
+(:trade GE 1.318640 :last 36.15)
+(:trade WMT 1.320354 :last 48.41)
+(:trade HPQ 1.322354 :last 21.04)
+(:trade AIG 1.331152 :last 53.59)
+(:close)
+|#
+
+(defun msg-start (m)
+ (search "TRADEDATA" m))
+
Added: dependencies/trunk/cells/cell-types.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cell-types.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,190 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+(defstruct (cell (:conc-name c-))
+ model
+ slot-name
+ value
+
+ inputp ;; t for old c-variable class
+ synaptic
+ (caller-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify callers FIFO
+
+ (state :nascent :type symbol) ;; :nascent, :awake, :optimized-away
+ (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :uncurrent | :valid}
+ ; uncurrent (aka dirty) new for 06-10-15. we need this so
+ ; c-quiesce can force a caller to update when asked
+ ; in case the owner of the quiesced cell goes out of existence
+ ; in a way the caller will not see via any kids dependency. Saw
+ ; this one coming a long time ago: depending on cell X implies
+ ; a dependency on the existence of instance owning X
+ (pulse 0 :type fixnum)
+ (pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP
+ (pulse-observed 0 :type fixnum)
+ lazy
+ (optimize t)
+ debug
+ md-info)
+
+
+
+;_____________________ print __________________________________
+
+#+sigh
+(defmethod print-object :before ((c cell) stream)
+ (declare (ignorable stream))
+ #+shhh (unless (or *stop* *print-readably*)
+ (format stream "[~a~a:" (if (c-inputp c) "i" "?")
+ (cond
+ ((null (c-model c)) #\0)
+ ((eq :eternal-rest (md-state (c-model c))) #\_)
+ ((not (c-currentp c)) #\#)
+ (t #\space)))))
+
+(defmethod print-object ((c cell) stream)
+ (declare (ignorable stream))
+ (if *stop*
+ (format stream "<~d:~a ~a/~a = ~a>"
+ (c-pulse c)
+ (subseq (string (c-state c)) 0 1)
+ (symbol-name (or (c-slot-name c) :anoncell))
+ (md-name (c-model c))
+ (type-of (c-value c)))
+ (let ((*print-circle* t))
+ #+failsafe (format stream "~a/~a" (c-model c)(c-slot-name c))
+ (if *print-readably*
+ (call-next-method)
+ (progn
+ (c-print-value c stream)
+ (format stream "<~d:~a ~a/~a = ~a>"
+ (c-pulse c)
+ (subseq (string (c-state c)) 0 1)
+ (symbol-name (or (c-slot-name c) :anoncell))
+ (print-cell-model (c-model c))
+ (if (consp (c-value c))
+ "LST" (c-value c))))))))
+
+(export! print-cell-model)
+
+(defgeneric print-cell-model (md)
+ (:method (other) (print-object other nil)))
+
+(defmethod trcp :around ((c cell))
+ (and ;*c-debug*
+ (or (c-debug c)
+ (call-next-method))))
+
+(defun c-callers (c)
+ "Make it easier to change implementation"
+ (fifo-data (c-caller-store c)))
+
+(defun caller-ensure (used new-caller)
+ (unless (find new-caller (c-callers used))
+ (trc nil "caller-ensure fifo-adding new-caller" new-caller :used used)
+ (fifo-add (c-caller-store used) new-caller)))
+
+(defun caller-drop (used caller)
+ (fifo-delete (c-caller-store used) caller))
+
+; --- ephemerality --------------------------------------------------
+;
+; Not a type, but an option to the :cell parameter of defmodel
+;
+(defun ephemeral-p (c)
+ (eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c))))
+
+(defun ephemeral-reset (c)
+ (when (ephemeral-p c) ;; so caller does not need to worry about this
+ ;
+ ; as of Cells3 we defer resetting ephemerals because everything
+ ; else gets deferred and we cannot /really/ reset it until
+ ; within finish_business we are sure all callers have been recalculated
+ ; and all outputs completed.
+ ;
+ ; ;; good q: what does (setf <ephem> 'x) return? historically nil, but...?
+ ;
+ ;;(trcx bingo-ephem c)
+ (with-integrity (:ephemeral-reset c)
+ (trc nil "!!!!!!!!!!!!!! ephemeral-reset resetting:" c)
+ (md-slot-value-store (c-model c) (c-slot-name c) nil)
+ (setf (c-value c) nil))))
+
+; -----------------------------------------------------
+
+(defun c-validate (self c)
+ (when (not (and (c-slot-name c) (c-model c)))
+ (format t "~&unadopted cell: ~s md:~s" c self)
+ (c-break "unadopted cell ~a ~a" self c)
+ (error 'c-unadopted :cell c)))
+
+(defstruct (c-ruled
+ (:include cell)
+ (:conc-name cr-))
+ (code nil :type list) ;; /// feature this out on production build
+ rule)
+
+(defun c-optimized-away-p (c)
+ (eq :optimized-away (c-state c)))
+
+;----------------------------
+
+(defmethod trcp-slot (self slot-name)
+ (declare (ignore self slot-name)))
+
+(defstruct (c-dependent
+ (:include c-ruled)
+ (:conc-name cd-))
+ ;; chop (synapses nil :type list)
+ (useds nil :type list)
+ (usage (blank-usage-mask)))
+
+(defun blank-usage-mask ()
+ (make-array 16 :element-type 'bit
+ :initial-element 0))
+
+(defstruct (c-drifter
+ (:include c-dependent)))
+
+(defstruct (c-drifter-absolute
+ (:include c-drifter)))
+
+;_____________________ accessors __________________________________
+
+(defmethod c-useds (other) (declare (ignore other)))
+(defmethod c-useds ((c c-dependent)) (cd-useds c))
+
+(defun c-validp (c)
+ (eql (c-value-state c) :valid))
+
+(defun c-unboundp (c)
+ (eql :unbound (c-value-state c)))
+
+
+;__________________
+
+(defmethod c-print-value ((c c-ruled) stream)
+ (format stream "~a" (cond ((c-validp c) (cons (c-value c) "<vld>"))
+ ((c-unboundp c) "<unb>")
+ ((not (c-currentp c)) "dirty")
+ (t "<err>"))))
+
+(defmethod c-print-value (c stream)
+ (declare (ignore c stream)))
+
Added: dependencies/trunk/cells/cells-manifesto.txt
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-manifesto.txt Tue Jan 26 15:20:07 2010
@@ -0,0 +1,592 @@
+In the text that follows, [xxx] signifies a footnote named "xxx" and
+listed alphabetically at the end.
+
+Summary
+-------
+Cells is a mature, stable extension to CLOS[impl] allowing one to create classes
+whose instances can have slot values determined by instance-specific formulas.
+
+Example
+-------
+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 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
+whether they have in fact selected a range of text.
+
+Meanwhile, the selection-range rule might be:
+
+(let (start)
+ (c? (if (mouse-down? .w.)
+ (bwhen (c (mouse-pos-to-char self (mouse-pos .w.)))
+ (if start
+ (list start c)
+ (setf start c)))
+ (setf start nil))))
+
+Now the only imperative code needed is some glue reading the OS event loop
+converting raw mouse down and mouse move events into window (the .w. symbol-macro)
+attributes such as mouse-down? and mouse-pos. The desired functionality is achieved
+by declarative rules which (like selection-range above) are entirely responsible for
+deciding the selection range.
+
+A final trick comes from slot observers. Suppose we are thinly wrapping a C GUI and need to
+do something in the C library to actually make menu items available or not.
+It might look something like this:
+
+ (defobserver enabled ((self menu-item) new-value old-value old-value-bound?)
+ (menu-item-set (c-ptr self) (if new-value 1 0)))
+
+ie, Some model attributes must be propagated outside the model as they change, and observers
+are callbacks we can provide to handle change.
+
+Motivation
+----------
+As a child I watched my father toil at home for hours over paper
+spreadsheets with pencil and slide rule. After he changed one value,
+he had to propagate that change to other cells by first remembering
+which other ones included the changed cell in their computation.
+Then he had to do the calculations for those, erase, enter...
+and then repeat that process to propagate those changes in a
+cascade across the paper.
+
+VisiCalc let my father take the formula he had in mind and
+put it into (declare it to) the electronic spreadsheet. Then VisiCalc
+could do the tedious work: recalculating, knowing what to recalculate,
+and knowing in what order to recalculate.
+
+Cells do for programmers what electronic spreadsheets did for my father.
+Without Cells, CLOS slots are like cells of a paper spreadsheet.
+A single key-down event can cause a cascade of change throughout an
+application. The programmer has to arrange for it all to happen,
+all in the right order: delete any selected text, insert
+the new character, re-wrap the text, update the undo mechanism, revisit
+the menu statuses ("Cut" is no longer enabled), update the scroll bars,
+possibly scroll the window, flag the file as unsaved...
+
+Here is a real-world case study:
+
+"The last company I worked with made a product that was a control unit
+for some mechanical devices, presenting both sensor readings coming in
+from those devices and an interface to program the devices. Consider
+it like a very sophisticated microwave oven, perhaps with a
+temperature probe.
+
+"The UI code was a frighteningly complex rat's nest. Input data
+arriving from the sensors changed certain state values, which caused
+the display to update, but the system state also changed, and rules
+had to be evaluated, the outcome of which might be tuning to the
+running job or warning messages presented to the user, and in the
+meantime the user may be adjusting the running job. I'm sure there are
+even more interactions I'm leaving out.
+
+"There was no "large idea" in this code to organize these dependencies
+or orchestrate the data flow. The individual facilities were
+well-formed enough: "message" input and output, GUI widgets and forms,
+real-world entities modeled as entities in the code. However, the
+connections between these things were ad-hoc and not formalized. Every
+change to the system would provoke defects, and the failure usually
+involved not propagating some event, propagating it at the wrong time,
+or propagating it to the wrong recipients."
+ --- Steven Harris, on comp.lang.lisp
+
+What Mr. Harris describes is what Fred Brooks [bullet] said was an essential
+property of software development, meaning by essential that there was no
+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. Mr. Eby was
+inspired by his involvement to develop Trellis, his own Cells work-alike library
+for Python.
+
+DEFMODEL and Slot types
+-----------------------
+Classes, some of whose slots may be mediated by Cells, are defined by DEFMODEL, which is exactly
+like DEFCLASS but adds support for two slot definition options, :cell and :unchanged-if. Classes
+defined by DEFMODEL can inherit from normal CLOS classes.
+
+New slot definition options
+----------------------------
+
+ :cell {nil | t | :ephemeral}
+
+:cell is optional. The default is ":cell t", meaning the Cells engine will manage the slot to give
+it the spreadsheet-like characteristics. Specifying NIL signifies that this slot is entirely
+outside any handling by the Cells engine; it is just a plain CLOS slot.
+
+This next bit will not make sense until we have explained propagation of state change, but
+specifying :ephemeral causes the Cells engine to reset the apparent slot
+value to NIL immediately and only after fully propagating any value assumed by the slot, either
+by assignment to an input Cell (the vastly more common case) or by a rule calculation.
+
+Ephemeral cells are necessary to correctly model events in the otherwise steady-state
+spreadsheet paradigm.
+
+ :unchanged-if <function-name>
+
+Specifying :unchanged-if is optional. [Come to think of it, it should be an error to specify
+both :cell nil and :unchanged-if.] If specified, the named function is a predicate
+of two arguments, the new and old value in that order. The predicate determines if a subsequent
+slot value (either computed or assigned to an input) is unchanged in the sense that no propagation
+is necessary, either to dependent ruled cells or (getting ahead of ourselves again) "on change" observers.
+The default unchanged test is EQL.
+
+Cell types
+----------
+The Cells library allows the programmer to specify at make-instance time that a Cell
+slot of an instance be mediated for the life of that instance by one of:
+
+ -- a so-called "input" Cell;
+ -- a "ruled" Cell; or
+ -- no Cell at all.
+
+Note that different instances of the same class may do different things Cells-wise with the same slot.
+One label widget may have a fixed width of 42 and text "Hi, Mom!", where another might have
+an input Cell mediating the text (so edit logic can assign new values as the user types) and a
+rule mediating the width so the widget can have a minimum width of 42(so it does not disappear altogether)
+yet grow based on text length and relevant font metrics to always leave room for one more character
+(if the GUI design calls for that).
+
+To summarize, the class specification supplied with DEFMODEL specifies whether a slot can /ever/
+be managed by the Cells engine. For those that can, at and only at instance initialization time
+different instances can have different Cell types and rules specified to mediate the same slot.
+
+Input Cells
+-----------
+A slot mediated by an input Cell may be assigned new values at runtime. These are how Cell-based models
+get data from the world outside the model -- it cannot be rules all the way down. Typically, these
+input assignements are made by code polling OS events via some GetNextEvent API call, or by callbacks
+registered with an event system such as win32 WindowProc functions. Other code may poll sockets or
+serial inputs from an external device.
+
+Ruled Cells
+-----------
+Ruled Cells come with an instance-specific rule in the form of an anonymous function of two variables,
+the instance owning the slot and the prior value (if any) computed by the rule. These rules consist of
+arbitrarily complex Common Lisp code, and are invoked immediately after instance initialization (but see
+the next bit on lazy cells).
+
+When a rule runs, any dynamic read (either expressly in the rule source or during the execution of
+some function invoked by the rule) of a slot of any instance mediated by a Cell of any type establishes a
+runtime dependency of the ruled cell on the slot of the instance that was read. Note then that thanks
+to code branching, dependencies can vary after every rule invocation.
+
+Lazy Ruled Cells
+----------------
+Laziness is cell-specific, applies only to ruled cells, and comes in four varieties:
+
+ :once-asked -- this will get evaluated and "observed" on initialization, but then not get reevaluated
+immediately if dependencies change, rather only when read by application code.
+
+ :until-asked -- this does not get evaluated/observed until read by application code, but then it becomes
+un-lazy, eagerly reevaluated as soon as any dependency changes (not waiting until asked).
+
+ :always -- not evaluated/observed until read, and not reevaluated until read after a dependency changes.
+
+Dataflow
+--------
+When application code assigns a new value to an input Cell (a quick way of saying an instance slot mediated by
+an input Cell) -- typically by code polling OS events or a socket or an input device -- a cascade of recalculation
+ensues to bring direct and indirect ruled dependents current with the new value assigned to the input Cell.
+
+No Cell at All
+--------------
+Because of all that, it is an error to assign a new value to a slot of an instance not mediated by any Cell.
+The Cells engine can do a handy optimization by treating such slots as constants and not creating dependencies when ruled
+Cells read these. But then we cannot let these Cells vary and still guarantee data integrity, because
+we no longer know who else to update in light of such variation. The optimization, by the way, extends to
+eliminating ruled Cells which, after any computation, end up not depending on any other cell.
+
+Again, note that this is different from specifying ":cell nil" for some slot. Here, the Cells engine
+has been told to manage some slot, but for some instance the slot has been authored to bear some value
+for the lifetime of that instance.
+
+Observers
+---------
+To allow the emergent animated data model to operate usefully on the world outside the model--if only to
+update the screen--programmers may specify so-called observer callbacks dispatched according to: slot name,
+instance, new value, old value, and whether the old value actually existed (false only on the first go).
+Observers are inherited according to the rules of CLOS class inheritance. If multiple primary observer
+methods apply because of inheritance, they all get run, most specific last.
+
+ie, observers are a GF with PROGN method combination.
+
+Observers get called in two circumstances: as part of Model object initialization, in a processing step
+just after CLOS instance initialization, and when a slot changes value. Any observer of a Cell slot
+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 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
+a cycle, where changing slot A requires a change to slot B, and changing slot B requires a change to
+slot A, such as the scroll thumb position and the amount a document has been scrolled.
+
+Finally, to make it possible for such a declarative model to talk intelligibly to imperative systems such as
+Tcl/Tk which sometimes requires a precise sequence of commands for something to work at all, a mechanism exists by
+which client code can (a) queue tasks for execution after a data change has fully propagated and (b) process
+those tasks with a client-supplied handler. Tasks are queued with arbitrary keying data which can be used by
+the handler to sort or compress the queued tasks.
+
+
+Data Integrity
+--------------
+When application code assigns to some input cell X, the Cells engine guarantees:
+
+ - recomputation exactly once of all and only state affected by the change to X, directly or indirectly through
+ some intermediate datapoint. note that if A depends on B, and B depends on X, when B gets recalculated
+ it may come up with the same value as before. In this case A is not considered to have been affected
+ 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 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
+
+ - a corollary: should a client observer SETF a datapoint Y, all the above must
+ happen with values current with not just X, but also with the value of Y /prior/
+ to the change to Y.
+
+ - Deferred "client" code must see only values current with X and not any values current with some
+ subsequent change to Y queued by an observer
+
+Benefits
+--------
+Program state guaranteed to be self-consistent, without programmer effort. Dependencies are identified
+by the engine, and change propagation happens automatically.
+
+Greater object re-use. Slots of instances can be authored with rules, not just literal values. In a sense,
+we get greater reuse by allowing instances to override slot derivations instance by instance. But not slot
+expressions, which are still class-oriented. By this I mean the observers expressing changes in value are
+dispatched by the class of the instance and so are not instance-specific. (Such a thing has been
+suggested, however.) Another strong bit of class-orientation comes from the fact that code reading
+slot X of some instance Y obviously does so without knowing how the returned value was derived. It knows
+only that the slot is named X, and will do things with that value assuming only that it has the
+X attribute of the instance Y. So again: the derivation of a slot value is potentially instance-oriented
+under Cells, but its expression or manifestation is still class-oriented.
+
+Natural decomposition of overall application complexity into so many simple rules and slot observers.
+Let's return for a moment to VisiCalc and its descendants. In even the most complex financial spreadsheet
+model, no one cell rule accesses more than a relatively few other spreadsheet cells (counting a row or
+column range as one reference). Yet the complex model emerges. All the work of tracking dependencies
+is handled by the spreadsheet software, which requires no special declaration by the modeller. They simply
+write the Cell rule. In writing the rule, they are concerned only with the derivation of one datapoint from
+a population of other datapoints. No effort goes into arranging for the rule to get run at the right time,
+and certainly no energy is spent worrying about what other cells might be using the authored cell. That
+cell has certain semantics -- "account balance", perhaps -- and the modeller need only worry about writing
+a correct, static computation of those semantics.
+
+Same with Cells. :) The only difference is that VisiCalc has one "observer" requirement for all cells:
+update the screen. In Cells applications, a significant amount of application functionality -- indeed, all
+its outputs -- end up in cell observers. But as discussed above, this additional burden falls only on
+the class designer when they decide to add a slot to a class. As instances are created and different rules
+specified for different slots to achieve custom behavior, the effort is the same as for the VisiCalc user.
+
+Model Building
+--------------
+Everything above could describe one instance of one class defined by DEFMODEL. A real application has
+multiple instances of multiple classes. So...
+
+-- cells can depend on other cells from any other instance. Since a rule gets passed only "self", Cell users
+need something like the Family class included with the Cells package effectively to turn a collection of
+instances into a network searchable by name or type.
+
+-- The overall model population must be maintainable by Cell slots such as the "kids" slot of the Family
+class. The burden here is on the Cells engine to allow one cell of one child to ask for the value of a cell of
+another child and vice versa (with different Cells), when both children are the product of the same rule,
+or different rules when "cousins" are exchanging information. So we must gracefully traverse the parent/kids
+tree dispatching kids rules just in time to produce the other instance sought.
+
+-- kid-slotting: used almost exclusively so far for orderly GUI layout, a parent must be able to specify
+rules for specific slots of kids. Example: a "stack" class wants to provide rules for child geometry
+specifying left, right, or centered alignment and vertical stacking (with optional spacing) one below
+the other. The idea is that we want to author classes of what might be GUI subcomponents without worrying
+about how they will be arranged in some container.
+
+-- finalization: when an instance appears in the "old kids" but not in the "new kids", a Cells engine
+may need to arrange for all Cells to "unsubscribe" from their dependents. Cells takes care of that if
+one calls "not-to-be" on an instance.
+
+
+Suggested Applications
+----------------------
+Any application that must maintain an interesting, long-lived data model incorporating a stream of unpredictable
+data. Two examples: any GUI application and a RoboCup soccer client.
+
+An application needing to shadow data between two systems. Examples: a Lisp GUI imlemented by thinly wrapping a
+C GUI library, where Lisp-land activity must be propagated to the C GUI, and C GUI events must propagate
+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 (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 in software used to
+schedule Hubble telescope viewing time. [COSI]
+
+Garnet's KR: http://www.cs.cmu.edu/~garnet/
+Also written in Lisp. Cells looks much like KR, though Cells was
+developed in ignorance of KR (or any other prior art). KR has
+an astonishing number of backdoors to its constraint
+engine, none of which have turned out to be necessary for Cells.
+
+The entire constraint programming field, beginning I guess with Guy Steele's
+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:
+
+See also:
+ The spreadsheet paradigm: http://www.cs.utk.edu/~bvz/active-value-spreadsheet.html
+ The dataflow paradigm: http://en.wikipedia.org/wiki/Dataflow
+ Frame-based programming
+ Definitive-programming
+
+Commentary
+----------
+-- Jack Unrue, comp.lang.lisp
+"Cells provides the plumbing for data dependency management which every
+non-trivial program must have; a developer using Cells can focus on
+computing program state and reacting to state changes, leaving Cells to worry about
+how that state is propagated. Cells does this by enabling a declarative
+mechanism built via an extension to CLOS, and hence achieves its goal in a way
+that meshes well with with typical Common Lisp programming style."
+
+-- Bill Clementson, http://bc.tech.coop/blog/030911.html
+"Kenny Tilton has been talking about his Cells implementation on comp.lang.lisp
+for some time but I've only just had a look at it over the past few evenings.
+It's actually pretty neat. Kenny describes Cells as, conceptually, analogous to
+a spreadsheet cell (e.g. -- something in which you can put a value or a formula
+and have it updated automatically based on changes in other "cell" values).
+Another way of saying this might be that Cells allows you to define classes
+whose slots can be dynamically (and automatically) updated and for which
+standard observers can be defined that react to changes in those slots."
+
+-- "What is Cells?", Cells-GTk FAQ, http://common-lisp.net/project/cells-gtk/faq.html#q2
+"If you are at all familiar with developing moderately complex software that
+is operated through a GUI, then you have probably
+learned this lesson: Keeping what is presented through the GUI in-sync with what
+the user is allowed to do, and in-sync with the computational state of the
+program is often tedious, complicated work. .... Cells-GTK helps
+with these tasks by providing an abstraction over the details; each of the tasks
+just listed can be controlled by (a) formula that specify the value of
+attributes of graphic features in the part-subpart declaration (that declaration
+is called 'defpart' in cells-gtk); and, (b) formula that specify the value of CLOS slots."
+
+-- Phillip Eby, PyCells and peak.events,
+ http://www.eby-sarna.com/pipermail/peak/2006-May/002545.html
+"What I discovered is quite cool. The Cells system *automatically
+discovers* dynamic dependencies, without having to explicitly specify that
+X depends on Y, as long as X and Y are both implemented using cell
+objects. The system knows when you are computing a value for X, and
+registers the fact that Y was read during this computation, thus allowing
+it to automatically invalidate the X calculation if Y changes....
+Aside from the automatic dependency detection, the cells system has
+another trick that is able to significantly reduce the complexity of
+event cascades, similar to what I was trying (but failing) to do using
+the "scheduled thread" concept in peak.events.
+Specifically, the cells system understands how to make event-based updates
+orderly and deterministic, in a way that peak.events cannot. It
+effectively divides time into "propagation" and "non-propagation"
+states. Instead of simply making callbacks whenever a computed value
+changes, the system makes orderly updates by queueing invalidated cells for
+updating. Also, if you write code that sets a new value imperatively (as
+opposed to it being pulled declaratively), the actual set operation is
+deferred until all computed cells are up-to-date with the current state of
+the universe."
+
+_____________
+Uncommentary
+
+-- Peter Seibel, comp.lang.lisp:
+"I couldn't find anything that explained what [Cells] was and why I should care."
+
+-- Alan Crowe, comp.lang.lisp:
+"Further confession: I'm bluffing. I've grasped that Cells is
+interesting, but I haven't downloaded it yet, and I haven't
+checked out how it works or what /exactly/ it does."
+
+_________
+Footnotes
+
+[Adam] "Adam is a modeling engine and declarative language for describing constraints and
+relationships on a collection of values, typically the parameters to an
+application command. When bound to a human interface (HI) Adam provides
+the logic that controls the HI behavior. Adam is similar in concept to a spreadsheet
+or a forms manager. Values are set and dependent values are recalculated.
+Adam provides facilities to resolve interrelated dependencies and to track
+those dependencies, beyond what a spreadsheet provides."
+http://opensource.adobe.com/group__asl__overview.html#asl_overview_intro_to_adam_and_eve
+________
+[bullet] This resolves a problem Fred Brooks identified in 1987: ""The essence of a software
+entity is a construct of interlocking concepts: data sets, relationships among data items, algorithms,
+and invocations of functions... Software systems have orders-of-magnitude more states than
+computers do...a scaling-up of a software entity is not merely a repetition of the same elements
+in larger sizes; it is necessarily an increase in the number of different elements. In most cases,
+the elements interact with each other in some nonlinear fashion, and the complexity of the whole
+increases much more than linearly."
+-- http://www.virtualschool.edu/mon/SoftwareEngineering/BrooksNoSilverBullet.html
+______
+[COSI] "The Constraint Sequencing Infrastructure (COSI) is an extension to
+the Common Lisp Object System (*(CLOS)) which supports a constraint
+based object-oriented programming model. .....
+
+"A constraint is a specialized method which will be automatically
+re-run by the COSI infrastructure whenever any of its input values
+change. Input values are any of the object attributes that are
+accessed by the constraint, and which are therefore assumed to
+alter the processing within the constraint.
+
+"Whenever a state change occurs those constraints which depend upon
+that state are added to a propagation queue. When the system is
+queried a propagation cycle runs ensuring that the state of the
+system is consistent with all constraints prior to returning a value."
+-- http://www.cliki.net/ACL2/COSI?source
+______
+[impl] The Cells library as it stands is all about doing interesting things
+with slots of CLOS instances, but Cells is not only about CLOS or even Lisp.
+One Cells user is known to have mediated a global variable with a Cell, some work
+was done on having slots of DEFSTRUCTs mediated by Cells, and ports to C++, Java, and
+Python have been explored.
+
+_______
+[axiom] Phillip Eby's axiomatic specification of Cells:
+
+Data Pulse Axioms
+=================
+
+Overview: updates must be synchronous (all changed cells are updated at
+once), consistent (no cell rule sees out of date values), and minimal (only
+necessary rules run).
+
+1. Global Update Counter:
+ There is a global update counter. (Guarantees that there is a
+globally-consistent notion of the "time" at which updates occur.)
+
+2. Per-Cell "As Of" Value:
+ Every cell has a "current-as-of" update count, that is initialized with
+a value that is less than the global update count will ever be.
+
+3. Out-of-dateness:
+ A cell is out of date if its update count is lower than the update
+count of any of the cells it depends on.
+
+4. Out-of-date Before:
+ When a rule-driven cell's value is queried, its rule is only run if the
+cell is out of date; otherwise a cached previous value is
+returned. (Guarantees that a rule is not run unless its dependencies have
+changed since the last time the rule was run.)
+
+5. Up-to-date After:
+ Once a cell's rule is run (or its value is changed, if it is an input
+cell), its update count must be equal to the global update
+count. (Guarantees that a rule cannot run more than once per update.)
+
+6. Inputs Move The System Forward
+ When an input cell changes, it increments the global update count and
+stores the new value in its own update count.
+
+
+Dependency Discovery Axioms
+===========================
+
+Overview: cells automatically notice when other cells depend on them, then
+notify them at most once if there is a change.
+
+
+1. Thread-local "current rule cell":
+ There is a thread-local variable that always contains the cell whose
+rule is currently being evaluated in the corresponding thread. This
+variable can be empty (e.g. None).
+
+2. "Currentness" Maintenance:
+ While a cell rule's is being run, the variable described in #1 must be
+set to point to the cell whose rule is being run. When the rule is
+finished, the variable must be restored to whatever value it had before the
+rule began. (Guarantees that cells will be able to tell who is asking for
+their values.)
+
+3. Dependency Creation:
+ When a cell is read, it adds the "currently-being evaluated" cell as a
+listener that it will notify of changes.
+
+4. Dependency Creation Order:
+ New listeners are added only *after* the cell being read has brought
+itself up-to-date, and notified any *previous* listeners of the
+change. (Ensures that the listening cell does not receive redundant
+notification if the listened-to cell has to be brought up-to-date first.)
+
+5. Dependency Minimalism:
+ A listener should only be added if it does not already present in the
+cell's listener collection. (This isn't strictly mandatory, the system
+behavior will be correct but inefficient if this requirement isn't met.)
+
+6. Dependency Removal:
+ Just before a cell's rule is run, it must cease to be a listener for
+any other cells. (Guarantees that a dependency from a previous update
+cannot trigger an unnecessary repeated calculation.)
+
+7. Dependency Notification
+ Whenever a cell's value changes (due to a rule change or input change),
+it must notify all of its listeners that it has changed, in such a way that
+*none* of the listeners are asked to recalculate their value until *all* of
+the listeners have first been notified of the change. (This guarantees
+that inconsistent views cannot occur.)
+
+7a. Deferred Recalculation
+ The recalculation of listeners (not the notification of the listeners'
+out-of-dateness) must be deferred if a cell's value is currently being
+calculated. As soon as there are no cells being calculated, the deferred
+recalculations must occur. (This guarantees that in the absence of
+circular dependencies, no cell can ask for a value that's in the process of
+being calculated.)
+
+8. One-Time Notification Only
+ A cell's listeners are removed from its listener collection as soon as
+they have been notified. In particular, the cell's collection of listeners
+must be cleared *before* *any* of the listeners are asked to recalculate
+themselves. (This guarantees that listeners reinstated as a side effect of
+recalculation will not get a duplicate notification in the current update,
+or miss a notification in a future update.)
+
+9. Conversion to Constant
+ If a cell's rule is run and no dependencies were created, the cell must
+become a "constant" cell, and do no further listener additions or
+notification, once any necessary notifications to existing listeners are
+completed. (That is, if the rule's run changed the cell's value, it must
+notify its existing listeners, but then the listener collection must be
+cleared -- *again*, in addition to the clearing described in #8.)
+
+10. No Changes During Notification:
+ It is an error to change an input cell's value while change
+notifications are taking place.
+
+11. Weak Notification
+ Automatically created inter-cell links must not inhibit garbage
+collection of either cell. (Technically optional, but very easy to do.)
+
+
Added: dependencies/trunk/cells/cells-store.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-store.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,248 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells Store -- Dependence on a Hash-Table
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+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 :cells)
+
+(export! cells-store bwhen-c-stored c?-with-stored with-store-item store-add store-lookup store-remove store-items)
+
+(defmacro c?-with-stored ((var key store &optional default) &body body)
+ `(c? (bwhen-c-stored (,var ,key ,store ,default)
+ , at body)))
+
+(defmacro bwhen-c-stored ((var key store &optional if-not) &body body)
+ (with-gensyms (gkey gstore glink gifnot)
+ `(let ((,gkey ,key)
+ (,gstore ,store)
+ (,gifnot ,if-not))
+ (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
+ , at body)
+ ,gifnot)))))
+
+(defmodel cells-store (family)
+ ((data :accessor data :initarg :data :cell nil))
+ (:default-initargs
+ :data (make-hash-table)))
+
+;;; infrastructure for manipulating the store and kicking rules
+
+(defmethod entry (key (store cells-store))
+ (gethash key (data store)))
+
+(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
+ (symbol-macrolet ((,item '(item key store)))
+ (progn
+ , at body))
+ (kick-c-link ,key ,store)))
+
+
+(defmacro with-store-entry ((key store &key quiet) &body body)
+ `(prog1
+ (progn
+ , at body)
+ (unless ,quiet
+ (kick-c-link ,key ,store))))
+
+;;; item management
+
+(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)
+ (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)))
+
+(defmethod store-items ((store cells-store) &key (include-keys nil))
+ (loop for key being the hash-keys in (data store)
+ for val being the hash-values in (data store)
+ if (and (cdr val) include-keys) collect (cons key (cdr val))
+ else if (cdr val) collect it))
+
+;;; 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")
+ , at body
+ (let ((superfluous-observers (loop for run in *observers* if (not (member run (list , at asserted-observers))) collect run))
+ (failed-observers (loop for asserted in (list , at asserted-observers) if (not (member asserted *observers*)) collect asserted)))
+ (trc "called observers on" *observers* :superflous superfluous-observers :failed failed-observers)
+ (assert (not superfluous-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)))))
+ (bypass-lookup? (make-instance 'family :value (c-in t)))
+ (baz (make-instance 'test-store-item :value (c? (if (value bypass-lookup?)
+ 'no-lookup
+ (bwhen-c-stored (v :bar store 'nothing)
+ (value v)))))))
+
+ (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))
+
+ (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))
+
+ (assert-values ("deleted foo")
+ (foo 'nothing)
+ (foo+1 'nothing)
+ (bar 2)
+ (bar-1 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)
+ (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
Added: dependencies/trunk/cells/cells-test/boiler-examples.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/boiler-examples.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,290 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+;;
+;; OK, nothing new here, just some old example code I found lying around. FWIW...
+;;
+
+(defmodel boiler1 ()
+ ((id :cell nil :initarg :id :accessor id :initform (random 1000000))
+ (status :initarg :status :accessor status :initform nil) ;; vanilla cell
+ (temp :initarg :temp :accessor temp :initform nil)
+ (vent :initarg :vent :accessor vent :initform nil)
+ ))
+
+(def-cell-test boiler-1 ()
+
+ ;; resets debugging/testing specials
+ (cells-reset)
+
+ (let ((b (make-instance 'boiler1
+ :temp (c-in 20)
+ :status (c? (if (< (temp self) 100)
+ :on
+ :off))
+ :vent (c? (ecase (^status) ;; expands to (status self) and also makes coding synapses convenient
+ (:on :open)
+ (:off :closed))))))
+
+ (ct-assert (eql 20 (temp b)))
+ (ct-assert (eql :on (status b)))
+ (ct-assert (eql :open (vent b)))
+
+ (setf (temp b) 100) ;; triggers the recalculation of status and then of vent
+
+ (ct-assert (eql 100 (temp b)))
+ (ct-assert (eql :off (status b)))
+ (ct-assert (eql :closed (vent b)))
+ ))
+
+#+(or)
+(boiler-1)
+
+;
+; now let's see how output functions can be used...
+; and let's also demonstrate inter-object dependency by
+; separating out the thermometer
+;
+
+;;; note that thermometer is just a regular slot, it is
+;;; not cellular.
+
+(defmodel boiler2 ()
+ ((status :initarg :status :accessor status :initform nil)
+ (vent :initarg :vent :accessor vent :initform nil)
+ (thermometer :cell nil :initarg :thermometer :accessor thermometer :initform nil)
+ ))
+
+;;; defobserver ((slot-name) (&optional method-args) &body body
+
+;;; the defobserver macro defines a method with
+;;; three arguments -- by default, these arguments are named
+;;; self -- bound to the instance being operated on
+;;; old-value -- bound to the previous value of the cellular slot
+;;; named slot-name, of the instance being operated on.
+;;; new-value -- bound to the new value of said cellular slot
+
+;;; (this is why the variables self, old-value, and new-value can exist
+;;; below in the body, when it appears they are not defined in any
+;;; lexical scope)
+
+;;; the body of the macro defines code which is executed
+;;; when the the slot-name slot is initialized or changed.
+
+(defobserver status ((self boiler2))
+ (trc "output> boiler status" self :oldstatus= old-value :newstatus= new-value)
+ ;
+ ; << in real life call boiler api here to actually turn it on or off >>
+ ;
+ )
+
+(defobserver vent ((self boiler2))
+ (trc "output> boiler vent changing from" old-value :to new-value)
+ ;
+ ; << in real life call boiler api here to actually open or close it >>
+ ;
+ )
+
+
+(defmodel quiet-thermometer ()
+ ((temp :initarg :temp :accessor temp :initform nil)
+ ))
+
+(defmodel thermometer (quiet-thermometer)())
+
+;;; notice instead of oldvalue and newvalue, here the
+;;; old and new values are bound to parameters called oldtemp
+;;; and newtemp
+
+(defobserver temp ((self thermometer) newtemp oldtemp)
+ (trc "output> thermometer temp changing from" oldtemp :to newtemp))
+
+;--------------------------
+
+
+;;; here we introduce the to-be-primary construct, which causes
+;;; immediate initialization of cellular slots.
+
+;;; notice how the status cell of a boiler2 can depend
+;;; on the temp slot of a thermometer, illustrating how
+;;; dependencies can be made between the cellular slots of
+;;; instances of different classes.
+
+
+(def-cell-test boiler-2 ()
+ (cells-reset)
+ (let ((b (make-instance 'boiler2
+ :status (c? (eko ("boiler2 status c?")
+ (if (< (temp (thermometer self)) 100)
+ :on :off)))
+ :vent (c? (ecase (^status)
+ (:on :open)
+ (:off :closed)))
+ :thermometer (make-instance 'thermometer
+ :temp (c-in 20)))))
+
+ (ct-assert (eql 20 (temp (thermometer b))))
+ (ct-assert (eql :on (status b)))
+ (ct-assert (eql :open (vent b)))
+
+ (setf (temp (thermometer b)) 100)
+
+ (ct-assert (eql 100 (temp (thermometer b))))
+ (ct-assert (eql :off (status b)))
+ (ct-assert (eql :closed (vent b)))
+ ))
+
+#+(or)
+(boiler-2)
+
+;;; ***********************************************
+;;; ***********************************************
+;;; ***********************************************
+
+#| intro to cells, example 3 |#
+
+;;; ***********************************************
+;;; ***********************************************
+;;; ***********************************************
+
+
+;;; note: we use boiler2 and thermometer from example 2 in example 3,
+;;; along with their def-output methods defined in example 2.
+;;;
+;;; also: these do not use ct-assert to perform automatic testing, but
+;;; they do illustrate a possible real-world application of synapses. to
+;;; observe the difference made by synapses, one must look at the trace output
+;
+; now let's look at synapses, which mediate a dependency between two cells.
+; the example here has an input argument (sensitivity-enabled) which when
+; enables gives the temp cell an (fsensitivity 0.05) clause.
+
+; the example simulates a thermometer perhaps
+; malfunctioning which is sending streams of values randomly plus or minus
+; two-hundredths of a degree. does not sound serious, except...
+;
+; if you run the example as is, when the temperature gets to our on/off threshhold
+; of 100, chances are you will see the boiler toggle itself on and off several times
+; before the temperature moves away from 100.
+;
+; building maintenance personel will report this odd behavior, probably hearing the
+; vent open and shut and open again several times in quick succession.
+
+; the problem is traced to the cell rule which reacts too slavishly to the stream
+; of temperature values. a work order is cut to replace the thermometer, and to reprogram
+; the controller not to be so slavish. there are lots of ways to solve this; here if
+; you enable sensitivity by running example 4 you can effectively place a synapse between the
+; temperature cell of the thermometer and the status cell of the boiler which
+; does not even trigger the status cell unless the received value differs by the
+; specified amount from the last value which was actually relayed.
+
+; now the boiler simply cuts off as the temperature passes 100, and stays off even if
+; the thermometer temperature goes to 99.98. the trace output shows that although the temperature
+; of the thermometer is changing, only occasionally does the rule to decide the boiler
+; status get kicked off.
+;
+
+
+
+(def-cell-test boiler-3 (&key (sensitivity-enabled t))
+ (declare (ignorable sensitivity-enabled))
+ (cells-reset)
+ #+soon
+ (let ((b (make-instance 'boiler2
+ :status (c? (let ((temp (if sensitivity-enabled
+ (temp (thermometer self) (f-sensitivity 0.05))
+ (temp (thermometer self)))))
+ ;;(trc "status c? sees temp" temp)
+ (if (< temp 100) :on :off)
+ ))
+ :vent (c? (ecase (^status) (:on :open) (:off :closed)))
+ :thermometer (make-instance 'quiet-thermometer :temp (c-in 20))
+ )))
+ ;
+ ; let's simulate a thermometer which, when the temperature is actually
+ ; any given value t will indicate randomly anything in the range
+ ; t plus/minus 0.02. no big deal unless the actual is exactly our
+ ; threshold point of 100...
+ ;
+ (dotimes (x 4)
+ ;;(trc "top> ----------- set base to" (+ 98 x))
+ (dotimes (y 10)
+ (let ((newtemp (+ 98 x (random 0.04) -.02))) ;; force random variation around (+ 98 x)
+ ;;(trc "top> ----------- set temp to" newtemp)
+ (setf (temp (thermometer b)) newtemp))))))
+
+
+(def-cell-test boiler-4 () (boiler-3 :sensitivity-enabled t))
+
+;;
+;; de-comment 'trc statements above to see what is happening
+;;
+#+(or)
+(boiler-3)
+
+#+(or)
+(boiler-4)
+
+(def-cell-test boiler-5 ()
+
+ (cells-reset)
+ #+soon
+ (let ((b (make-instance 'boiler2
+ :status (c-in :off)
+ :vent (c? (trc "caculating vent" (^status))
+ (if (eq (^status) :on)
+ (if (> (temp (thermometer self) (f-debug 3)) 100)
+ :open :closed)
+ :whatever-off))
+ :thermometer (make-instance 'quiet-thermometer
+ :temp (c-in 20)))))
+
+ (dotimes (x 4)
+ (dotimes (n 4)
+ (incf (temp (thermometer b))))
+ (setf (status b) (case (status b) (:on :off)(:off :on))))))
+
+#+(or)
+
+(boiler-5)
+
+(def-cell-test f-debug (sensitivity &optional subtypename)
+ (declare (ignore sensitivity subtypename))
+ #+soon
+ (mk-synapse (prior-fire-value)
+ :fire-p (lambda (syn new-value)
+ (declare (ignorable syn))
+ (eko ("fire-p decides" prior-fire-value sensitivity)
+ (delta-greater-or-equal
+ (delta-abs (delta-diff new-value prior-fire-value subtypename) subtypename)
+ (delta-abs sensitivity subtypename)
+ subtypename)))
+
+ :fire-value (lambda (syn new-value)
+ (declare (ignorable syn))
+ (eko ("f-sensitivity relays")
+ (setf prior-fire-value new-value)) ;; no modulation of value, but do record for next time
+ )))
Added: dependencies/trunk/cells/cells-test/build-sys.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/build-sys.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,56 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-user; -*-
+;;;
+;;; Copyright © 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(defpackage #:cells-build-package
+ (:use #:cl))
+
+(in-package #:cells-build-package)
+
+(defun build-sys (system$ &key source-directory force)
+ (let (
+ ;;; --------------------------------------
+ ;;; Step 2: Implementation-specific issues
+ ;;;
+ ;;; Let's assume this is fixed in CMUCL 19a, and fix it later if need be.
+ #+cmu18
+ (ext:*derive-function-types* nil)
+
+ #+lispworks
+ (hcl::*handle-existing-defpackage* (list :add))
+ )
+
+ ;;----------------------------------------
+ ;; source-directory validation...
+ ;;
+ (assert (pathnamep source-directory)
+ (source-directory)
+ "source-directory not supplied, please edit build.lisp to specify the location of the source.")
+ (let ((project-asd (merge-pathnames (format nil "~a.asd" system$)
+ source-directory)))
+ (unless (probe-file project-asd)
+ (error "~a not found. revise build.lisp if asd file is somewhere else." project-asd)))
+
+ ;;;----------------------------------
+ ;;; ok. build...
+ ;;;
+ (push source-directory asdf:*central-registry*)
+ (asdf:operate 'asdf:load-op (intern system$ :keyword) :force force)))
\ No newline at end of file
Added: dependencies/trunk/cells/cells-test/cells-test.asd
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/cells-test.asd Tue Jan 26 15:20:07 2010
@@ -0,0 +1,26 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+
+(asdf:defsystem :cells-test
+ :name "cells-test"
+ :author "Kenny Tilton <ktilton at nyc.rr.com>"
+ :maintainer "Kenny Tilton <ktilton at nyc.rr.com>"
+ :licence "MIT Style"
+ :description "Cells Regression Test/Documentation"
+ :long-description "Informatively-commented regression tests for Cells"
+ :serial t
+ :depends-on (:cells)
+ :components ((:file "test")
+ (:file "hello-world")
+ (:file "test-kid-slotting")
+ (:file "test-lazy")
+ (:file "person")
+ (:file "df-interference")
+ (:file "test-family")
+ (:file "output-setf")
+ (:file "test-cycle")
+ (:file "test-ephemeral")
+ (:file "test-synapse")
+ (:file "deep-cells")))
+
+
+
Added: dependencies/trunk/cells/cells-test/cells-test.lpr
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/cells-test.lpr Tue Jan 26 15:20:07 2010
@@ -0,0 +1,104 @@
+;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*-
+
+(in-package :cg-user)
+
+(defpackage :CELLS)
+
+(define-project :name :cells-test
+ :modules (list (make-instance 'module :name "test.lisp")
+ (make-instance 'module :name "hello-world.lisp")
+ (make-instance 'module :name "test-kid-slotting.lisp")
+ (make-instance 'module :name "test-lazy.lisp")
+ (make-instance 'module :name "person.lisp")
+ (make-instance 'module :name "df-interference.lisp")
+ (make-instance 'module :name "test-family.lisp")
+ (make-instance 'module :name "output-setf.lisp")
+ (make-instance 'module :name "test-cycle.lisp")
+ (make-instance 'module :name "test-ephemeral.lisp")
+ (make-instance 'module :name "test-synapse.lisp")
+ (make-instance 'module :name "deep-cells.lisp")
+ (make-instance 'module :name "clos-training.lisp")
+ (make-instance 'module :name "do-req.lisp"))
+ :projects (list (make-instance 'project-module :name "..\\cells"
+ :show-modules nil))
+ :libraries nil
+ :distributed-files nil
+ :internally-loaded-files nil
+ :project-package-name :cells
+ :main-form nil
+ :compilation-unit t
+ :verbose nil
+ :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 (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 (list :read-init-files nil)
+ :old-space-size 256000
+ :new-space-size 6144
+ :runtime-build-option :standard
+ :build-number 0
+ :on-initialization 'cells::test-cells
+ :on-restart 'do-default-restart)
+
+;; End of Project Definition
Added: dependencies/trunk/cells/cells-test/deep-cells.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/deep-cells.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,53 @@
+(in-package :cells)
+
+(defvar *client-log*)
+(defvar *obs-1-count*)
+
+(defmodel deep ()
+ ((cell-2 :cell :ephemeral :initform (c-in 'two) :accessor cell-2)
+ (cell-1 :initform (c? (list 'one (^cell-2) (^cell-3))) :accessor cell-1)
+ (cell-3 :initform (c-in 'c3-unset) :accessor cell-3)))
+
+(defobserver cell-1 ()
+ (trc "cell-1 observer raw now enqueing client to run first. (new,old)=" new-value old-value)
+ (with-integrity (:client 1)
+ (trc "cell-1 :client now running" new-value (incf *obs-1-count*))
+ (eko ("c1-obs->*client-log*: ")
+ (setf *client-log* (list new-value)))))
+
+(defobserver cell-2 ()
+ (trc "cell-2 observer raw now enqueing change and client to run second. (new,old)=" new-value old-value)
+ (with-integrity (:change)
+ (trc "cell-2 observer :change now running" *client-log*)
+ (ct-assert (equal *client-log* '((one two c3-unset) two c3-unset)))
+ (setf (^cell-3) (case new-value (two 'three) (otherwise 'trouble))))
+ (with-integrity (:client 2)
+ (trc "client cell-2 :client running")
+ (eko ("c2-obs->*client-log*: ")
+ (setf *client-log* (append *client-log* (list new-value))))))
+
+(defobserver cell-3 ()
+ (trc "cell-3 observer raw now enqueing client to run third. (new,old)=" new-value old-value)
+ (with-integrity (:client 3)
+ (trc "cell-3 observer :client now running" new-value)
+ (eko ("c3-obs->*client-log*: ")
+ (setf *client-log* (append *client-log* (list new-value))))))
+
+(defun deep-queue-handler (client-q)
+ (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 :user-q defer-info)))
+
+(def-cell-test go-deep ()
+ (cells-reset 'deep-queue-handler)
+ (setf *obs-1-count* 0)
+ (make-instance 'deep)
+ (ct-assert (eql 2 *obs-1-count*)) ;; because the cell-2 observer does a setf on something used by c1
+ (trc "testing *client-log*" *client-log*)
+ (ct-assert (tree-equal *client-log* '((one nil three) three))))
+
+
+
Added: dependencies/trunk/cells/cells-test/df-interference.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/df-interference.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,120 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defvar *eex* 0)
+
+(defmodel xx3 ()
+ ((aa :initform (c-in 0) :initarg :aa :accessor aa)
+ (dd :initform (c? (min 0 (+ (^cc) (^bb)))) :initarg :dd :accessor dd)
+ (ddx :initform (c? (+ (^cc) (^bb))) :initarg :ddx :accessor ddx)
+ (cc :initform (c? (+ (^aa) (^bb))) :initarg :cc :reader cc)
+ (bb :initform (c? (* 2 (^aa))) :initarg :bb :accessor bb)
+ (ee :initform (c? (+ (^aa) (^dd))) :initarg :ee :reader ee)
+ (eex :initform (c? (trc "in rule of eex, *eex* now" *eex*)
+ (+ (^aa) (^ddx))) :initarg :eex :reader eex)
+ ))
+
+(defobserver aa ((self xx3))
+ (trc nil "output aa:" new-value))
+
+(defobserver bb ((self xx3))
+ (trc nil "output bb:" new-value))
+
+(defobserver cc ((self xx3))
+ (trc nil "output cc:" new-value))
+
+(defobserver dd ((self xx3))
+ (trc nil "output dd:" new-value))
+
+(defobserver ee ((self xx3))
+ (trc nil "output ee:" new-value))
+
+(defobserver eex ((self xx3))
+ (incf *eex*)
+ (trc "output eex:" new-value *eex*))
+
+;;
+;; here we look at just one problem, what i call dataflow interference. consider
+;; a dependency graph underlying:
+;;
+;; - a depends on b and c, and...
+;; - b depends on c
+;;
+;; if c changes, depending on the accident of the order in which a and b happened to
+;; be first evaluated, a might appear before b on c's list of dependents (callers). then the
+;; following happens:
+;;
+;; - c triggers a
+;; - a calculates off the new value of c and an obsolete cached value for b
+;; - a outputs an invalid value and triggers any dependents, all of whom recalculate
+;; using a's invalid value
+;; - c triggers b
+;; - b recalculates and then triggers a, which then recalculates correctly and outputs and triggers
+;; the rest of the df graph back into line
+;;
+;; the really bad news is that outputs go outside the model: what if the invalid output caused
+;; a missile launch? sure, a subsequent correct calculation comes along shortly, but
+;; irrevocable damage may have been done.
+;;
+
+(def-cell-test df-test ()
+ (cells-reset)
+ (let* ((*eex* 0)
+ (it (make-instance 'xx3)))
+ (trc "eex =" *eex*)
+ (ct-assert (eql *eex* 1))
+ ;;(inspect it);;(cellbrk)
+ (ct-assert (and (eql (aa it) 0)(eql (bb it) 0)(eql (cc it) 0)))
+ (ct-assert (and (eql (dd it) 0)(eql (ddx it) 0)(eql (ee it) 0)(eql (eex it) 0)))
+
+ ;;;- interference handling
+ ;;;
+ (let ((*eex* 0))
+ (trc "--------- 1 => (aa it) --------------------------")
+ (setf (aa it) 1)
+
+ (ct-assert (and (eql (aa it) 1)(eql (bb it) 2)(eql (cc it) 3)))
+ (trc "dd,ddx:" (dd it) (ddx it) )
+ (ct-assert (and (eql (dd it) 0)(eql (ddx it) 5)))
+ (ct-assert (and (eql (ee it) 1)(eql (eex it) 6)))
+ (ct-assert (eql *eex* 1)))
+
+ (let ((*eex* 0))
+ (trc "--------- 2 => (aa it) --------------------------")
+ (setf (aa it) 2)
+ (ct-assert (and (eql (aa it) 2)(eql (bb it) 4)(eql (cc it) 6)
+ (eql (dd it) 0)(eql (ddx it) 10)(eql (ee it) 2)(eql (eex it) 12)))
+ (ct-assert (eql *eex* 1)))
+
+ (dolist (c (cells it))
+ (trc "cell is" c)
+ (when (typep (cdr c) 'cell)
+ (print `(notifier ,c))
+ (dolist (u (c-callers (cdr c)))
+ (print `(___ ,u)))))
+ ))
+
+
Added: dependencies/trunk/cells/cells-test/echo-setf.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/echo-setf.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,47 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defmodel bing (model)
+ ((bang :initform (c-in nil) :accessor bang)))
+
+(def-c-output bang ()
+ (bwhen (p .parent)
+ (setf (bang p) new-value)))
+
+(defmodel bings (bing family)
+ ()
+ (:default-initargs
+ :kids (c? (loop repeat 2
+ collect (make-instance 'bing)))))
+
+(defun cv-echo-setf ()
+ (cell-reset)
+ (let ((top (make-instance 'bings
+ :kids (c-in nil))))
+ (push (make-instance 'bings) (kids top))))
+
+#+(or)
+(cv-echo-setf)
Added: dependencies/trunk/cells/cells-test/hello-world-q.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/hello-world-q.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,81 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+;;;
+;;;(defstrudel computer
+;;; (happen :cell :ephemeral :initform (c-in nil))
+;;; (location :cell t
+;;; :initform (c? (case (^happen)
+;;; (:leave :away)
+;;; (:arrive :at-home)
+;;; (t (c-value c))))
+;;; :accessor location)
+;;; (response :cell :ephemeral :initform nil :initarg :response :accessor response)))
+
+(def-c-output response((self computer) new-response old-response)
+ (when new-response
+ (format t "~&computer: ~a" new-response)))
+
+(def-c-output happen((self computer))
+ (when new-value
+ (format t "~&happen: ~a" new-value)))
+
+(defun hello-world-q ()
+ (let ((dell (make-instance 'computer
+ :response (c? (bwhen (h (happen self))
+ (if (eql (^location) :at-home)
+ (case h
+ (:knock-knock "who's there?")
+ (:world "hello, world."))
+ "<silence>"))))))
+ (dotimes (n 2)
+ (setf (happen dell) :knock-knock))
+ (setf (happen dell) :arrive)
+ (setf (happen dell) :knock-knock)
+ (setf (happen dell) :world)
+ (values)))
+
+#+(or)
+(hello-world)
+
+#+(or)
+(traceo sm-echo)
+
+
+#| output
+
+happen: knock-knock
+computer: <silence>
+happen: knock-knock
+computer: <silence>
+happen: arrive
+happen: knock-knock
+computer: who's there?
+happen: world
+computer: hello, world.
+
+|#
+
Added: dependencies/trunk/cells/cells-test/hello-world.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/hello-world.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,78 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+
+(defmd computer ()
+ (happen (c-in nil) :cell :ephemeral)
+ (location (c? (case (^happen)
+ (:leave :away)
+ (:arrive :at-home)
+ (t .cache)))) ;; ie, unchanged
+ (response nil :cell :ephemeral))
+
+(defobserver response(self new-response old-response)
+ (when new-response
+ (format t "~&computer: ~a" new-response)))
+
+(defobserver happen()
+ (when new-value
+ (format t "~&happen: ~a" new-value)))
+
+(def-cell-test hello-world ()
+ (let ((dell (make-instance 'computer
+ :response (c? (bwhen (h (happen self))
+ (if (eql (^location) :at-home)
+ (case h
+ (:knock-knock "who's there?")
+ (:world "hello, world."))
+ "<silence>"))))))
+ (dotimes (n 2)
+ (setf (happen dell) :knock-knock))
+
+ (setf (happen dell) :arrive)
+ (setf (happen dell) :knock-knock)
+ (setf (happen dell) :leave)
+ (values)))
+
+#+(or)
+(hello-world)
+
+
+#| output
+
+happen: KNOCK-KNOCK
+computer: <silence>
+happen: KNOCK-KNOCK
+computer: <silence>
+happen: ARRIVE
+happen: KNOCK-KNOCK
+computer: who's there?
+happen: LEAVE
+computer: <silence>
+
+
+|#
+
Added: dependencies/trunk/cells/cells-test/internal-combustion.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/internal-combustion.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,362 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+
+(in-package :cells)
+
+(defmodel engine ()
+ ((fuel :cell nil :initarg :fuel :initform nil :accessor fuel)
+ (cylinders :initarg :cylinders :initform (c-in 4) :accessor cylinders)
+ (valves-per-cylinder :initarg :valves-per-cylinder :initform 2 :accessor valves-per-cylinder)
+ (valves :initarg :valves
+ :accessor valves
+ :initform (c? (* (valves-per-cylinder self)
+ (cylinders self))))
+ (mod3 :initarg :mod3 :initform nil :accessor mod3)
+ (mod3ek :initarg :mod3ek :initform nil :accessor mod3ek)
+ ))
+
+(defmethod c-unchanged-test ((self engine) (slotname (eql 'mod3)))
+ (lambda (new-value old-value)
+ (flet ((test (it) (zerop (mod it 3))))
+ (eql (test new-value) (test old-value)))))
+
+(defobserver mod3ek () (trc "mod3ek output" self))
+
+(defmethod c-unchanged-test ((self engine) (slotname (eql 'mod3ek)))
+ (lambda (new-value old-value)
+ (flet ((test (it) (zerop (mod it 3))))
+ (eql (test new-value) (test old-value)))))
+
+(defobserver cylinders ()
+ ;;(when *dbg* (break))
+ (trc "cylinders output" self old-value new-value))
+
+(defvar *propagations* nil)
+
+(defmodel engine-w-initform ()
+ ((cylinders :initform 33 :reader cylinders)))
+
+(defclass non-model ()())
+(defmodel faux-model (non-model)())
+(defmodel true-model ()())
+(defmodel indirect-model (true-model)())
+
+
+(def-cell-test cv-test-engine ()
+ (when *stop* (break "stopped! 2"))
+ ;;
+ ;; before we get to engines, a quick check that we are correctly enforcing the
+ ;; requirment that classes defined by defmodel inherit from model-object
+ ;;
+ (ct-assert (make-instance 'non-model))
+ (ct-assert (make-instance 'true-model))
+ (ct-assert (make-instance 'indirect-model))
+ (ct-assert (handler-case
+ (progn
+ (make-instance 'faux-model)
+ nil) ;; bad to reach here
+ (t (error) (trc "error is" error)
+ error)))
+ ;; --------------------------------------------------------------------------
+ ;; -- make sure non-cell slots still work --
+ ;;
+ ;; in mop-based implementations we specialize the slot-value-using-class accessors
+ ;; to make cells work. rather than slow down all slots where a class might have only
+ ;; a few cell-mediated slots, we allow a class to pick and choose which slots are cell-mediated.
+ ;;
+ ;; here we make sure all is well in re such mixing of cell and non-cell, by exercising first
+ ;; the reader and then the writer.
+ ;;
+ ;; the read is not much of a test since it should work even if through some error the slot
+ ;; gets treated as if it were cell. but the setf will fail since cell internals reject changes
+ ;; to cellular slots unless they are c-variable. (why this is so has to do with efficiency,
+ ;; and will be covered when we get to cells being optimized away.)
+ ;;
+ (ct-assert
+ (eql :gas (fuel (make-instance 'engine :fuel :gas))))
+ (ct-assert
+ (eql :diesel (setf (fuel (make-instance 'engine :fuel :gas)) :diesel)))
+ ;;
+ ;;
+ #+(or) ;; not an error: Cloucell needed to hold a Cell in a non cellular slot. duh.
+ (ct-assert
+ (handler-case
+ (progn
+ (make-instance 'engine :fuel (c-in :gas))
+ nil) ;; bad to reach here
+ (t (error) (trc "error is" error)
+ error)))
+ ;;
+ ;; ---------------------------------------------------------------------------
+ ;; (1) reading cellular slots (2) instantiated as constant, variable or ruled
+ ;;
+ ;; aside from the simple mechanics of successfuly accessing cellular slots, this
+ ;; code exercises the implementation task of binding a cell to a slot such that
+ ;; a standard read op finds the wrapped value, including a functional value (the c?)
+ ;;
+ ;; aside; the cell pattern includes a transparency requirement so cells will be
+ ;; programmer-friendly and in turn yield greater productivity gains. below we /initialize/
+ ;; the cylinders cell to (c-in 4) and then (c? (+ 2 2)), but when you read those slots the
+ ;; cell implementation structures are not returned, the value 4 is returned.
+ ;;
+ ;; aside: the value 4 itself occupies the actual slot. this helped when we used Cells
+ ;; with a persistent CLOS tool which maintained inverse indices off slots if asked.
+ ;;
+ (ct-assert
+ (progn
+ (eql 33 (cylinders (make-instance 'engine-w-initform)))))
+
+ (ct-assert
+ (eql 4 (cylinders (make-instance 'engine :cylinders 4))))
+
+ (ct-assert
+ (eql 4 (cylinders (make-instance 'engine :cylinders (c-in 4)))))
+
+ (ct-assert
+ (eql 4 (cylinders (make-instance 'engine :cylinders (c? (+ 2 2))))))
+
+ (ct-assert
+ (eql 16 (valves (make-instance 'engine
+ :cylinders 8
+ :valves (c? (* (cylinders self) (valves-per-cylinder self)))
+ :valves-per-cylinder (c? (floor (cylinders self) 4)))))) ;; admittedly weird semantics
+
+ ;; ----------------------------------------------------------
+ ;; initialization output
+ ;;
+ ;; cells are viewed in part as supportive of modelling. the output functions provide
+ ;; a callback allowing state changes to be manifested outside the dataflow, perhaps
+ ;; by updating the screen or by operating some real-world device through its api.
+ ;; that way a valve model instance could drive a real-world valve.
+ ;;
+ ;; it seems best then that the state of model and modelled should as much as possible
+ ;; be kept consistent with each other, and this is why we "output" cells as soon as they
+ ;; come to life as well as when they change.
+ ;;
+ ;; one oddball exception is that cellular slots for which no output is defined do not get outputted
+ ;; initially. why not? this gets a little complicated.
+ ;;
+ ;; first of all, outputting requires evaluation of a ruled cell. by checking first
+ ;; if a cell even is outputted, and punting on those that are not outputted we can defer
+ ;; the evaluation of any ruled cell bound to an unoutputted slot until such a slot is
+ ;; read by other code. i call this oddball because it is a rare slot that is
+ ;; neither outputted nor used directly or indirectly by an outputted slot. but i have had fairly
+ ;; expensive rules on debugging slots which i did not want kicked off until i had
+ ;; to check their values in the inspector. ie, oddball.
+ ;;
+
+ (macrolet ((output-init (newv cylini)
+ `(progn
+ (output-clear 'cylinders)
+ (output-clear 'valves)
+ (trc "starting output init test" ,newv ',cylini)
+ (make-instance 'engine
+ :cylinders ,cylini
+ :valves ,cylini)
+ (ct-assert (outputted 'cylinders))
+ (ct-assert (eql ,newv (output-new 'cylinders)))
+ ;(ct-assert (not (output-old-boundp 'cylinders)))
+ ;(ct-assert (not (outputted 'valves)))
+ )))
+ (output-init 6 6)
+ (output-init 10 (c-in 10))
+ (output-init 5 (c? (+ 2 3)))
+ )
+
+ ;; ----------------------------------------------------------------
+ ;; write cell slot
+ ;;
+ ;; for now only variable cells (slots mediated by c-variable structures) can be
+ ;; modified via setf. an exception (drifter cells) may get resurrected soon. but as mentioned
+ ;; above, an optimization discussed below requires rejection of changes to cellular slots
+ ;; instantiated without any cell, and for purity the cell engine rejects setf's of slots mediated
+ ;; by ruled cells. the idea being that we want the semantics of a ruled
+ ;; cell to be fully defined by its rule, not arbitrary setf's from anywhere in the code.
+ ;;
+ ;; aside: variable cells can be setf'ed from anywhere, a seeming loss of semantic
+ ;; control by the above purist view. but variables exist mainly to allow inputs to a dataflow model
+ ;; from outside the model, usually in an event-loop processing os events, so spaghetti dataflow
+ ;; should not follow from this.
+ ;;
+ ;; that said, in weak moments i resort to having the output of one cell setf some other variable cell,
+ ;; but i always think of these as regrettable gotos and maybe someday i will try to polish them out
+ ;; of existence test.
+ ;;
+ ;;-------------------------
+ ;;
+ ;; first verify acceptable setf...
+ ;;
+ (ct-assert
+ (let ((e (make-instance 'engine :cylinders (c-in 4))))
+ (setf (cylinders e) 6)
+ (eql 6 (cylinders e))))
+ ;;
+ ;; ...and two not acceptable...
+ ;;
+ (ct-assert
+ (handler-case
+ (let ((e (make-instance 'engine :cylinders 4)))
+ (setf (cylinders e) 6)
+ nil) ;; bad to reach here
+ (t (error)
+ (trc "error correctly is" error)
+ (cells-reset)
+ t))) ;; something non-nil to satisfy assert
+
+ (let ((e (make-instance 'engine :cylinders (c? (+ 2 2)))))
+ (assert *c-debug*)
+ (ct-assert
+ (handler-case
+ (progn
+ (setf (cylinders e) 6)
+ nil) ;; bad to reach here
+ (t (error) (trc "error correctly is" error)
+ (setf *stop* nil)
+ t))))
+ (when *stop* (break "stopped! 1"))
+ (cv-test-propagation-on-slot-write)
+ (cv-test-no-prop-unchanged)
+
+ ;;
+ ;; here we exercise a feature which allows the client programmer to override the default
+ ;; test of eql when comparing old and new values. above we defined nonsense slot mod3 (unoutputted)
+ ;; and mod3ek (outputted) with a custom "unchanged" test:
+ ;;
+
+ ;;
+ #+(or) (let ((e (make-instance 'engine
+ :mod3 (c-in 3)
+ :mod3ek (c-in 3)
+ :cylinders (c? (* 4 (mod3 self))))))
+
+ (ct-assert (eql 12 (cylinders e)))
+ (output-clear 'mod3)
+ (output-clear 'mod3ek)
+ (trc "mod3 outputes cleared, setting mod3s now")
+ (setf (mod3 e) 6
+ (mod3ek e) 6)
+ ;;
+ ;; both 3 and 6 are multiples of 3, so the engine guided by the above
+ ;; override treats the cell as unchanged; no output, no recalculation
+ ;; of the cylinders cell
+ ;;
+ (ct-assert (not (outputted 'mod3ek))) ;; no real need to check mod3 unoutputted
+ (ct-assert (eql 12 (cylinders e)))
+ ;;
+ ;; now test in the other direction to make sure change according to the
+ ;; override still works.
+ ;;
+ (setf (mod3 e) 5
+ (mod3ek e) 5)
+ (ct-assert (outputted 'mod3ek))
+ (ct-assert (eql 20 (cylinders e)))
+ )
+ )
+
+(def-cell-test cv-test-propagation-on-slot-write ()
+ ;; ---------------------------------------------------------------
+ ;; propagation (output and trigger dependents) on slot write
+ ;;
+ ;; propagation involves both outputing my change and notifying cells dependent on me
+ ;; that i have changed and that they need to recalculate themselves.
+ ;;
+ ;; the standard output callback is passed the slot-name, instance, new value,
+ ;; old value and a flag 'old-value-boundp indicating, well, whether the new value
+ ;; was the first ever for this instance.
+ ;;
+ ;; the first set of tests make sure actual change is handled correctly
+ ;;
+ (output-clear 'cylinders)
+ (output-clear 'valves)
+ (output-clear 'valves-per-cylinder)
+ (when *stop* (break "stopped!"))
+ (let ((e (make-instance 'engine
+ :cylinders 4
+ :valves-per-cylinder (c-in 2)
+ :valves (c? (* (valves-per-cylinder self) (cylinders self))))))
+ ;;
+ ;; these first tests check that cells get outputted appropriately at make-instance time (the change
+ ;; is from not existing to existing)
+ ;;
+ (ct-assert (and (eql 4 (output-new 'cylinders))
+ (not (output-old-boundp 'cylinders))))
+
+ (ct-assert (valves-per-cylinder e)) ;; but no output is defined for this slot
+
+ (ct-assert (valves e))
+ ;;
+ ;; now we test true change from one value to another
+ ;;
+ (setf (valves-per-cylinder e) 4)
+ ;;
+ (ct-assert (eql 16 (valves e)))
+ ))
+
+(def-cell-test cv-test-no-prop-unchanged ()
+ ;;
+ ;; next we check the engines ability to handle dataflow efficiently by /not/ reacting
+ ;; to coded setfs which in fact produce no change.
+ ;;
+ ;; the first takes a variable cylinders cell initiated to 4 and again setf's it to 4. we
+ ;; confirm that the cell does not output and that a cell dependent on it does not get
+ ;; triggered to recalculate. ie, the dependency's value has not changed so the dependent
+ ;; cell's cached value remains valid.
+ ;;
+ (cells-reset)
+ (output-clear 'cylinders)
+ (let* ((*dbg* t)
+ valves-fired
+ (e (make-instance 'engine
+ :cylinders (c-in 4)
+ :valves-per-cylinder 2
+ :valves (c-formula (:lazy t)
+ (setf valves-fired t)
+ (trc "!!!!!! valves")
+ (* (valves-per-cylinder self) (cylinders self))))))
+ (trc "!!!!!!!!hunbh?")
+ (ct-assert (outputted 'cylinders))
+ (output-clear 'cylinders)
+ (ct-assert (not valves-fired)) ;; no output is defined so evaluation is deferred
+ (trc "sampling valves....")
+ (let ()
+ (ct-assert (valves e)) ;; wake up unoutputted cell
+ )
+ (ct-assert valves-fired)
+ (setf valves-fired nil)
+
+ (ct-assert (and 1 (not (outputted 'cylinders))))
+ (setf (cylinders e) 4) ;; same value
+ (trc "same cyl")
+ (ct-assert (and 2 (not (outputted 'cylinders))))
+ (ct-assert (not valves-fired))
+
+ (setf (cylinders e) 6)
+ (ct-assert (outputted 'cylinders))
+ (ct-assert (not valves-fired))
+ (ct-assert (valves e))(ct-assert valves-fired)))
+
+#+(or)
+
+(cv-test-engine)
Added: dependencies/trunk/cells/cells-test/lazy-propagation.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/lazy-propagation.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,82 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defvar *area*)
+(defvar *density*)
+
+(defmodel cirkl ()
+ ((radius :initform (c-in 10) :initarg :radius :accessor radius)
+ (area :initform (c?_ (incf *area*) (trc "in area rule it is now" *area*)
+ (* pi (^radius) (^radius))) :initarg :area :accessor area)
+ (density :initform (c?_ (incf *density*)
+ (/ 1000 (^area))) :initarg :density :accessor density)))
+
+
+#+(or)
+(cv-laziness)
+
+(def-cell-test cv-laziness ()
+ (macrolet ((chk (area density)
+ `(progn
+ (assert (= ,area *area*) () "area is ~a, should be ~a" *area* ,area)
+ (assert (= ,density *density*) () "density is ~a, should be ~a" *density* ,density)
+ (trc nil "cv-laziness ok with:" ,area ,density)))
+ )
+ (let ((*c-debug* t))
+ (cells-reset)
+
+ (let* ((*area* 0)
+ (*density* 0)
+ (it (make-instance 'cirkl)))
+ (chk 0 0)
+
+ (print `(area is ,(area it)))
+ (chk 1 0)
+
+ (setf (radius it) 1)
+ (chk 1 0)
+
+ (print `(area is now ,(area it)))
+ (chk 2 0)
+ (assert (= (area it) pi))
+
+ (setf (radius it) 2)
+ (print `(density is ,(density it)))
+ (chk 3 1)
+
+ (setf (radius it) 3)
+ (chk 3 1)
+ (print `(area is ,(area it)))
+ (chk 4 1)
+ it))))
+
+#+(or)
+(cv-laziness)
+
+(defobserver area ()
+ (trc "area is" new-value :was old-value))
+
+
Added: dependencies/trunk/cells/cells-test/output-setf.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/output-setf.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,59 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defmodel bing (model)
+ ((bang :initform (c-in nil) :accessor bang)))
+
+(defobserver bang ()
+ (trc "new bang" new-value self)
+ (bwhen (p .parent)
+ (with-integrity (:change)
+ (setf (bang p) new-value)))
+ #+(or) (dolist (k (^kids))
+ (setf (bang k) (if (numberp new-value)
+ (1+ new-value)
+ 0))))
+
+(defmodel bings (bing family)
+ ()
+ (:default-initargs
+ :kids (c? (loop repeat 2
+ collect (make-instance 'bing
+ :fm-parent self
+ :md-name (copy-symbol 'kid))))))
+
+(def-cell-test cv-output-setf ()
+ (cells-reset)
+ (let ((top (make-instance 'bings
+ :md-name 'top
+ :kids (c-in nil))))
+ (push (make-instance 'bings
+ :fm-parent top) (kids top))
+ (dolist (k (kids (car (kids top))))
+ (setf (bang k) (kid-no k)))))
+
+#+(or)
+(cv-output-setf)
Added: dependencies/trunk/cells/cells-test/person.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/person.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,324 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defvar *name-ct-calc* 0)
+
+(defmodel person ()
+ ((speech :cell :ephemeral :initform (c-in nil) :initarg :speech :accessor speech)
+ (thought :cell :ephemeral :initform (c? (speech self)) :initarg :thought :accessor thought)
+ (names :initform nil :initarg :names :accessor names)
+ (pulse :initform nil :initarg :pulse :accessor pulse)
+ (name-ct :initarg :name-ct :accessor name-ct
+ :initform (c? "name-ct"
+ (incf *name-ct-calc*)
+ (length (names self))))))
+
+#+test
+(progn
+ (cells-reset)
+ (inspect
+ (make-instance 'person
+ :names '("speedy" "chill")
+ :pulse (c-in 60)
+ :speech (c? (car (names self)))
+ :thought (c? (when (< (pulse self) 100) (speech self))))))
+
+(defobserver names ((self person) new-names)
+ (format t "~&you can call me ~a" new-names))
+
+(defmethod c-unchanged-test ((self person) (slotname (eql 'names)))
+ 'equal)
+
+(defvar *thought* "failed")
+(defvar *output-speech* "failed")
+
+(defobserver thought ((self person) new-value)
+ (when new-value
+ (trc "output thought" self new-value)
+ (setq *thought* new-value)
+ (trc "i am thinking" new-value)))
+
+(defobserver speech ()
+ (setf *output-speech* new-value))
+
+(defmodel sick ()
+ ((e-value :cell :ephemeral :initarg :e-value :accessor e-value)
+ (s-value :initarg :s-value :reader s-value)))
+
+(defobserver s-value ()
+ :test)
+
+(defobserver e-value ()
+ :test)
+
+(def-cell-test cv-test-person ()
+ (cv-test-person-1)
+ (cv-test-person-3)
+ (cv-test-person-4)
+ (cv-test-person-5)
+ ;; (cv-test-talker)
+ )
+
+(def-cell-test cv-test-person-1 ()
+ ;;
+ ;; a recent exchange with someone who has developed with others a visual
+ ;; programming system was interesting. i mentioned my dataflow thing, he mentioned
+ ;; they liked the event flow model. i responded that events posed a problem for
+ ;; cells. consider something like:
+ ;;
+ ;; (make-instance 'button
+ ;; :clicked (c-in nil)
+ ;; :action (c? (when (clicked self) (if (- (time-now *cg-system*) (last-click-time.....
+ ;;
+ ;; well, once the button is clicked, that cell has the value t. the rest of the rule executes
+ ;; and does whatever, the rule completes. finis? no. the time-now cell of
+ ;; the system instance continues to tick-tick-tick. at each tick the action cell gets triggered,
+ ;; and (here is the problem) the clicked cell still says t.
+ ;;
+ ;; the problem is that clicked is event-ish. the semantics are not "has it ever been clicked",
+ ;; they are more like "when the /passing/ click occurs...". we could try requiring the programmer
+ ;; always to execute:
+ ;;
+ ;; (setf (clicked it) t)
+ ;; (setf (clicked it nil)
+ ;;
+ ;; ...but in fact cells like this often are ruled cells which watch mouse actions and check if the
+ ;; mouse up was in the control where the mousedown occurred. so where to put a line of code
+ ;; to change clicked back to nil? a deep fix seemed appropriate: teach cells about events, so...
+ ;;
+ ;; cellular slots can be defined to be :ephemeral if the slot will be used for
+ ;; event-like data. [defining slots and not cells as ephemeral means one cannot arrange for such a
+ ;; slot to have a non-ephemeral value for one instance and ephemeral values for other instances. we
+ ;; easily could go the other way on this, but this seems right.]
+ ;;
+ ;; the way ephemerals work is this: when a new value arrives in an ephemeral slot it is outputted and
+ ;; propagated to dependent cells normally, but then internally the slot value is cleared to nil.
+ ;; thus during the output and any dataflow direct or indirect the value is visible to other code, but
+ ;; no longer than that. note that setting the slot back to nil bypasses propagation: no output, no
+ ;; triggering of slot dependents.
+ ;;
+ ;;
+ (let ((p (make-instance 'person :speech (c-in nil))))
+ ;;
+ ;; - ephemeral c-variable cells revert to nil if setf'ed non-nil later
+ ;;
+ (setf (speech p) "thanks for all the fish")
+ (ct-assert (null (speech p)))
+ (ct-assert (equal *output-speech* "thanks for all the fish"))
+ (ct-assert (equal *thought* "thanks for all the fish")) ;; thought is ephemeral as well, so tricky test
+ ;;
+ ;; now check the /ruled/ ephemeral got reset to nil
+ ;;
+ (ct-assert (null (thought p)))))
+
+
+
+(def-cell-test cv-test-person-3 ()
+ ;; -------------------------------------------------------
+ ;; dynamic dependency graph maintenance
+ ;;
+ ;; dependencies of a cell are those other cells actually accessed during the latest
+ ;; invocation of the rule. note that a cellular slot may be constant, not mediated by a
+ ;; cell, in which case the access does not record a dependency.
+ ;;
+ (let ((p (make-instance 'person
+ :names (c-in '("speedy" "chill"))
+ :pulse (c-in 60)
+ :speech "nice and easy does it"
+ :thought (c? (if (> (pulse self) 180)
+ (concatenate 'string (car (names self)) ", slow down!")
+ (speech self))))))
+ ;;
+ ;; with the (variable=1) pulse not > 80, the branch taken leads to (constant=0) speech, so:
+ ;;
+ (ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought)))))
+ ;;
+ ;; with the (variable=1) pulse > 80, the branch taken leads to (variable=1) names, so:
+ ;;
+ (setf (pulse p) 200)
+ (ct-assert (eql 2 (length (cd-useds (md-slot-cell p 'thought)))))
+ ;;
+ ;; let's check the engine's ability reliably to drop dependencies by lowering the pulse again
+ ;;
+ (setf (pulse p) 50)
+ (ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought)))))))
+
+
+(def-cell-test cv-test-person-4 ()
+ (let ((p (make-instance 'person
+ :names '("speedy" "chill")
+ :pulse (c-in 60)
+ :speech (c? (car (names self)))
+ :thought (c? (when (< (pulse self) 100) (speech self))))))
+ ;;
+ ;; now let's see if cells are correctly optimized away when:
+ ;;
+ ;; - they are defined and
+ ;; - all cells accessed are constant.
+ ;;
+ (ct-assert (null (md-slot-cell p 'speech)))
+ #-its-alive!
+ (progn
+ (ct-assert (assoc 'speech (cells-flushed p)))
+ (ct-assert (c-optimized-away-p (cdr (assoc 'speech (cells-flushed p))))))
+
+ (ct-assert (not (c-optimized-away-p (md-slot-cell p 'thought)))) ;; pulse is variable, so cannot opti
+ (ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))) ;; but speech is opti, so only 1 used
+ ))
+
+(def-cell-test cv-test-person-5 ()
+ ;;
+ ;; for now cells do not allow cyclic dependency, where a computation of a cell leads back
+ ;; to itself. we could do something like have the self-reference return the cached value
+ ;; or (for the first evaluation) a required seed value. we already have logic which says
+ ;; that, if setf on a variable cell cycles back to setf on the same cell we simply stop, so
+ ;; there is no harm on the propagation side. but so far no need for such a thing.
+ ;;
+ ;; one interesting experiment would be to change things so propagation looping back on itself
+ ;; would be allowed. we would likewise change things so propagation was breadth first. then
+ ;; state change, once set in motion, would continue indefinitely. (propagation would also have to
+ ;; be non-recursive.) we would want to check for os events after each propagation and where
+ ;; real-time synchronization was necessary do some extra work. this in contrast to having a timer
+ ;; or os null events artificially move forward the state of, say, a simulation of a physical system.
+ ;; allowing propagation to loop back on itslef means the system would simply run, and might make
+ ;; parallelization feasible since we already have logic to serialize where semantically necessary.
+ ;; anyway, a prospect for future investigation.
+ ;;
+ ;; make sure cyclic dependencies are trapped:
+ ;;
+ (cells-reset)
+ #+its-alive! t
+ #-its-alive!
+ (ct-assert
+ (handler-case
+ (progn
+ (pulse (make-instance 'person
+ :names (c? (trc "calculating names" self)
+ (maptimes (n (pulse self))))
+ :pulse (c? (trc "calculating pulse" self)
+ (length (names self)))))
+ nil)
+ (t (error)
+ (describe error)
+ (setf *stop* nil)
+ t))))
+;;
+;; we'll toss off a quick class to test tolerance of cyclic
+
+(defmodel talker8 ()
+ ((words8 :initform (c-input (:cyclicp t) "hello, world")
+ :initarg :words8 :accessor words8)
+ (idea8 :initform (c-in "new friend!") :initarg :idea8 :accessor idea8)
+ (mood8 :initform (c-in "happy as clam") :initarg :mood8 :accessor mood8)))
+
+(defmodel talker ()
+ ((words :initform (c-in "hello, world") :initarg :words :accessor words)
+ (idea :initform (c-in "new friend!") :initarg :idea :accessor idea)
+ ))
+
+(defobserver words ((self talker) new-words)
+ (trc "new words" new-words)
+ (setf (idea self) (concatenate 'string "idea " new-words)))
+
+(defmethod c-unchanged-test ((self talker) (slotname (eql 'words)))
+ 'string-equal)
+
+(defobserver idea ((self talker) new-idea)
+ (trc "new idea" new-idea)
+ (setf (words self) (concatenate 'string "say " new-idea)))
+
+(defmethod c-unchanged-test ((self talker) (slotname (eql 'idea)))
+ 'string-equal)
+
+(defobserver words8 ((self talker8) new-words8)
+ (trc "new words8, sets idea8 to same" new-words8 *causation*)
+ (with-integrity (:change)
+ (setf (idea8 self) (concatenate 'string "+" new-words8))))
+
+(defmethod c-unchanged-test ((self talker8) (slotname (eql 'words8)))
+ 'string-equal)
+
+(defobserver idea8 ((self talker8) new-idea8)
+ (trc "new idea8, sets mood8 to same" new-idea8 *causation*)
+ (with-integrity (:change)
+ (setf (mood8 self) (concatenate 'string "+" new-idea8))))
+
+(defmethod c-unchanged-test ((self talker8) (slotname (eql 'idea8)))
+ 'string-equal)
+
+(defobserver mood8 ((self talker8) new-mood8)
+ (trc "new mood8, sets words8 to same:" new-mood8 *causation*)
+ (with-integrity (:change)
+ (setf (words8 self) (concatenate 'string "+" new-mood8))))
+
+(defmethod c-unchanged-test ((self talker8) (slotname (eql 'mood8)))
+ 'string-equal)
+
+(defmacro ct-assert-error (&body body)
+ `(ct-assert
+ (handler-case
+ (prog1 nil
+ , at body)
+ (t (error)
+ (trc "ct-assert-error" error)
+ (setf *stop* nil)
+ t))))
+
+#+(or) ; FIXME: this test is borked
+(def-cell-test cv-test-talker ()
+ ;;
+ ;; make sure cyclic setf is trapped
+ ;;
+ (cells-reset)
+
+ ;;; (trc "start unguarded cyclic")
+ ;;;
+ ;;; (let ((tk (make-instance 'talker)))
+ ;;; (setf (idea tk) "yes")
+ ;;; (string-equal "yes" (words tk))
+ ;;; (setf (words tk) "no")
+ ;;; (string-equal "no" (idea tk)))
+
+ (trc "start guarded cyclic")
+
+ #+(or) (ct-assert-error
+ (let ((tk (make-instance 'talker)))
+ (setf (idea tk) "yes")
+ (ct-assert (string-equal "yes" (words tk)))
+ (setf (words tk) "no")
+ (ct-assert (string-equal "no" (idea tk)))))
+ ;;
+ ;; make sure cells declared to be cyclic are allowed
+ ;; and halt (because after the first cyclic setf the cell in question
+ ;; is being given the same value it already has, and propagation stops.
+ ;;
+ (make-instance 'talker8)
+ #+(or) (let ((tk (make-instance 'talker8)))
+ (setf (idea8 tk) "yes")
+ (string-equal "yes" (words8 tk))
+ (setf (words8 tk) "no")
+ (string-equal "no" (idea8 tk)))
+ )
Added: dependencies/trunk/cells/cells-test/synapse-testing.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/synapse-testing.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,77 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defmodel counter-10 ()
+ ((ct :initarg :ct :initform nil :accessor ct)
+ (ct10 :initarg :ct10 :initform nil
+ :accessor ct10)))
+
+(defun cv-test-f-sensitivity ()
+ (cell-reset)
+ (with-metrics (t nil "cv-test-f-sensitivity")
+ (let ((self (make-be 'counter-10
+ :ct (c-in 0)
+ :ct10 (c? (count-it :ct10-rule)
+ (f-sensitivity :dummy-id (10)
+ (^ct))))))
+ (cv-assert (zerop (^ct10)))
+ (loop for n below 30
+ do (cv-assert (eq (^ct10) (* 10 (floor (^ct) 10))))
+ (incf (ct self))))
+ (cv-assert (eql 4 (count-of :ct10-rule)))))
+
+(defun cv-test-f-delta ()
+ (cell-reset)
+ (with-metrics (t nil "cv-test-f-delta")
+ (let ((self (make-be 'counter-10
+ :ct (c-in 0)
+ :ct10 (c? (count-it :ct10-rule)
+ (trc "runnning ct10-rule 1")
+ (f-delta :dummy ()
+ (^ct))))))
+ (cv-assert (zerop (^ct10)))
+ (cv-assert (zerop (^ct)))
+ (loop for n below 4
+ do (trc "loop incf ct" n)
+ (incf (ct self) n)
+ (cv-assert (eql (^ct10) n))))
+ (cv-assert (eql 4 (count-of :ct10-rule))))
+
+ (with-metrics (t nil "cv-test-f-delta-sensitivity")
+ (let ((self (make-be 'counter-10
+ :ct (c-in 0)
+ :ct10 (c? (count-it :ct10-rule)
+ (f-delta :xxx (:sensitivity 4)
+ (^ct))))))
+ (cv-assert (null (^ct10)))
+ (cv-assert (zerop (^ct)))
+ (loop for n below 4
+ do (trc "loop incf ct" n)
+ (incf (ct self) n)
+ (ecase n
+ ((0 1 2) (cv-assert (null (^ct10))))
+ (3 (cv-assert (eql (^ct10) 6)))
+ (4 (cv-assert (eql (^ct10) 4)))))
+ (cv-assert (eql 2 (count-of :ct10-rule))))))
+
Added: dependencies/trunk/cells/cells-test/test-cycle.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test-cycle.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,79 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+
+
+(defmodel m-cyc ()
+ ((m-cyc-a :initform (c-in nil) :initarg :m-cyc-a :accessor m-cyc-a)
+ (m-cyc-b :initform (c-in nil) :initarg :m-cyc-b :accessor m-cyc-b)))
+
+(defobserver m-cyc-a ()
+ (print `(output m-cyc-a ,self ,new-value ,old-value))
+ (with-integrity (:change)
+ (setf (m-cyc-b self) new-value)))
+
+(defobserver m-cyc-b ()
+ (print `(output m-cyc-b ,self ,new-value ,old-value))
+ (with-integrity (:change)
+ (setf (m-cyc-a self) new-value)))
+
+(def-cell-test m-cyc () ;;def-cell-test m-cyc
+ (let ((m (make-instance 'm-cyc)))
+ (print `(start ,(m-cyc-a m)))
+ (setf (m-cyc-a m) 42)
+ (assert (= (m-cyc-a m) 42))
+ (assert (= (m-cyc-b m) 42))))
+
+#+(or)
+(m-cyc)
+
+(defmodel m-cyc2 ()
+ ((m-cyc2-a :initform (c-in 0) :initarg :m-cyc2-a :accessor m-cyc2-a)
+ (m-cyc2-b :initform (c? (1+ (^m-cyc2-a)))
+ :initarg :m-cyc2-b :accessor m-cyc2-b)))
+
+(defobserver m-cyc2-a ()
+ (print `(output m-cyc2-a ,self ,new-value ,old-value))
+ #+(or) (when (< new-value 45)
+ (setf (m-cyc2-b self) (1+ new-value))))
+
+(defobserver m-cyc2-b ()
+ (with-integrity (:change self)
+ (print `(output m-cyc2-b ,self ,new-value ,old-value))
+ (when (< new-value 45)
+ (setf (m-cyc2-a self) (1+ new-value)))))
+
+(def-cell-test m-cyc2
+ (let ((m (make-instance 'm-cyc2)))
+ (print '(start))
+ (setf (m-cyc2-a m) 42)
+ (describe m)
+ (assert (= (m-cyc2-a m) 44))
+ (assert (= (m-cyc2-b m) 45))
+ ))
+
+#+(or)
+(m-cyc2)
+
+
Added: dependencies/trunk/cells/cells-test/test-cyclicity.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test-cyclicity.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,94 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defmodel ring-node ()
+ ((router-ids :cell nil :initform nil :initarg :router-ids :accessor router-ids)
+ (system-status :initform (c-in 'up) :initarg :system-status :accessor system-status
+ :documentation "'up, 'down, or 'unknown if unreachable")
+ (reachable :initarg :reachable :accessor reachable
+ :initform (c? (not (null ;; convert to boolean for readable test output
+ (find self (^reachable-nodes .parent))))))))
+
+(defun up (self) (eq 'up (^system-status)))
+
+(defmodel ring-net (family)
+ (
+ (ring :cell nil :initform nil :accessor ring :initarg :ring)
+ (sys-node :cell nil :initform nil :accessor sys-node :initarg :sys-node)
+ (reachable-nodes :initarg :reachable-nodes :accessor reachable-nodes
+ :initform (c? (contiguous-nodes-up
+ (find (sys-node self) (^kids)
+ :key 'md-name))))
+ )
+ (:default-initargs
+ :kids (c? (assert (sys-node self))
+ (assert (find (sys-node self) (ring self)))
+ (loop with ring = (ring self)
+ for triples on (cons (last1 ring)
+ (append ring (list (first ring))))
+ when (third triples)
+ collect (destructuring-bind (ccw node cw &rest others) triples
+ (declare (ignorable others))
+ (print (list ccw node cw))
+ (make-instance 'ring-node
+ :md-name node
+ :router-ids (list ccw cw)))))))
+
+(defun contiguous-nodes-up (node &optional (visited-nodes (list)))
+ (assert (not (find (md-name node) visited-nodes)))
+
+ (if (not (up node))
+ (values nil (push (md-name node) visited-nodes))
+ (progn
+ (push (md-name node) visited-nodes)
+ (values
+ (list* node
+ (mapcan (lambda (router-id)
+ (unless (find router-id visited-nodes)
+ (multiple-value-bind (ups new-visiteds)
+ (contiguous-nodes-up (fm-other! node router-id) visited-nodes)
+ (setf visited-nodes new-visiteds)
+ ups)))
+ (router-ids node)))
+ visited-nodes))))
+
+(defun test-ring-net ()
+ (flet ((dump-net (net msg)
+ (print '----------------------)
+ (print `(*** dump-net ,msg ******))
+ (dolist (n (kids net))
+ (print (list n (system-status n)(reachable n)(router-ids n))))))
+ (cell-reset)
+ (let ((net (make-instance 'ring-net
+ :sys-node 'two
+ :ring '(one two three four five six))))
+ (dump-net net "initially")
+ (setf (system-status (fm-other! net 'three)) 'down)
+ (dump-net net "down goes three!!")
+ (setf (system-status (fm-other! net 'six)) 'down)
+ (dump-net net "down goes six!!!"))))
+
+#+do-it
+(test-ring-net)
+
\ No newline at end of file
Added: dependencies/trunk/cells/cells-test/test-ephemeral.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test-ephemeral.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,64 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+
+(defmodel m-ephem ()
+ ((m-ephem-a :cell :ephemeral :initform nil :initarg :m-ephem-a :accessor m-ephem-a)
+ (m-test-a :cell nil :initform nil :initarg :m-test-a :accessor m-test-a)
+ (m-ephem-b :cell :ephemeral :initform nil :initarg :m-ephem-b :accessor m-ephem-b)
+ (m-test-b :cell nil :initform nil :initarg :m-test-b :accessor m-test-b)))
+
+(defobserver m-ephem-a ()
+ (setf (m-test-a self) new-value))
+
+(defobserver m-ephem-b ()
+ (trc "out ephem-B copying to test-B" new-value)
+ (setf (m-test-b self) new-value))
+
+(def-cell-test m-ephem
+ (let ((m (make-instance 'm-ephem
+ :m-ephem-a (c-in nil)
+ :m-ephem-b (c? (prog2
+ (trc "Start calc ephem-B")
+ (* 2 (or (^m-ephem-a) 0))
+ (trc "Stop calc ephem-B"))))))
+ (ct-assert (null (slot-value m 'm-ephem-a)))
+ (ct-assert (null (m-ephem-a m)))
+ (ct-assert (null (m-test-a m)))
+ (ct-assert (null (slot-value m 'm-ephem-b)))
+ (ct-assert (null (m-ephem-b m)))
+ (ct-assert (zerop (m-test-b m)))
+ (trc "setting ephem-A to 3")
+ (setf (m-ephem-a m) 3)
+ (ct-assert (null (slot-value m 'm-ephem-a)))
+ (ct-assert (null (m-ephem-a m)))
+ (ct-assert (eql 3 (m-test-a m)))
+ ;
+ (ct-assert (null (slot-value m 'm-ephem-b)))
+ (ct-assert (null (m-ephem-b m)))
+ (ct-assert (eql 6 (m-test-b m)))
+ ))
+
+
+
Added: dependencies/trunk/cells/cells-test/test-family.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test-family.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,158 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defmodel human (family)
+ ((age :initarg :age :accessor age :initform 10)))
+
+(defobserver .kids ((self human))
+ (when new-value
+ (print `(i have ,(length new-value) kids))
+ (dolist (k new-value)
+ (trc "one kid is named" (md-name k) :age (age k)))))
+
+(defobserver age ((k human))
+ (format t "~&~a is ~d years old" (md-name k) (age k)))
+
+(def-cell-test cv-test-family ()
+ (cells-reset)
+ (let ((mom (make-instance 'human)))
+ ;
+ ; the real power of cells appears when a population of model-objects are linked by cells, as
+ ; when a real-word collection of things all potentially affect each other.
+ ;
+ ; i use the family class to create a simple hierarchy in which kids have a pointer to their
+ ; parent (.fm-parent, accessor fm-parent) and a parent has a cellular list of their .kids (accessor kids)
+ ;
+ ; great expressive power comes from having kids be cellular; the model population changes as
+ ; the model changes in other ways. but this creates a delicate timing problem: kids must be fully
+ ; spliced into the model before their ruled cellular slots can be accessed, because a cell rule
+ ; itself might try to navigate the model to get to a cell value of some other model-object.
+ ;
+ ; the cell engine handles this in two steps. first, deep in the state change handling code
+ ; the .kids slot gets special handling (this is new for 2002, and come to think of it i will
+ ; have to expose that hook to client code so others can create models from structures other
+ ; than family) during which the fm-parent gets populated, among other things. second, the output of
+ ; kids calls to-be on each kid.
+ ;
+ ; one consequence of this is that one not need call to-be on new instances being added to
+ ; a larger model family, it will be done as a matter of course.
+ ;
+ (push (make-instance 'human :fm-parent mom :md-name 'natalia :age (c-in 23)) (kids mom))
+ (push (make-instance 'human :fm-parent mom :md-name 'veronica :age (c? (- (age (fm-other natalia)) 6))) (kids mom))
+ (push (make-instance 'human :fm-parent mom :md-name 'aaron :age (c? (- (age (fm-other veronica)) 4))) (kids mom))
+ (push (make-instance 'human :fm-parent mom :md-name 'melanie :age (c? (- (age (fm-other veronica)) 12))) (kids mom))
+ ;
+ ; some of the above rules invoke the macro fm-other. that searches the model space, first searching the
+ ; kids of the starting point (which defaults to a captured 'self), then recursively up to the
+ ; parent and the parent's kids (ie, self's siblings)
+ ;
+ (flet ((nat-age (n)
+ (setf (age (fm-other natalia :starting mom)) n)
+ (dolist (k (kids mom))
+ (ct-assert
+ (eql (age k)
+ (ecase (md-name k)
+ (natalia n)
+ (veronica (- n 6))
+ (aaron (- n 10))
+ (melanie (- n 18))))))))
+ (nat-age 23)
+ (nat-age 30)
+ (pop (kids mom))
+ (nat-age 40))))
+
+#+(or)
+
+(cv-test-family)
+
+;------------ family-values ------------------------------------------
+;;;
+;;; while family-values is itself rather fancy, the only cell concept introduced here
+;;; is that cell rules have convenient access to the current value of the slot, via
+;;; the symbol-macro ".cache" (leading and trailing full-stops). to see this we need to
+;;; go to the definition of family-values and examine the rule for the kids cell:
+;;;
+;;; (c? (assert (listp (kidvalues self)))
+;;; (eko (nil "gridhost kids")
+;;; (let ((newkids (mapcan (lambda (kidvalue)
+;;; (list (or (find kidvalue .cache :key (kvkey self) :test (kvkeytest self))
+;;; (trc nil "family-values forced to make new kid" self .cache kidvalue)
+;;; (funcall (kidfactory self) self kidvalue))))
+;;; (^kidvalues))))
+;;; (nconc (mapcan (lambda (oldkid)
+;;; (unless (find oldkid newkids)
+;;; (when (fv-kid-keep self oldkid)
+;;; (list oldkid))))
+;;; .cache)
+;;; newkids))))
+;;;
+;;; for efficiency's sake, family-values (fvs) generate kids only as needed based on determining
+;;; kidvalues cell. wherever possible existing kids are kept. this is done by looking in the current
+;;; value of the kids slot for a kid matching each new kidvalue and reusing that. we cannot use the
+;;; accessor kids because the first time thru the cell is internally invalid, so the rule will get dispatched
+;;; again in an infinite loop if we go through the accessor protocol.
+;;;
+;;; mind you, we could just use slot-value; .cache is just a convenience.
+;;;
+(defmodel bottle (model)
+ ((label :initarg :label :initform "unlabeled" :accessor label)))
+
+#+(or)
+(cv-family-values)
+
+(def-cell-test cv-family-values ()
+ (let* ((kf-calls 0)
+ (wall (make-instance 'family-values
+ :kv-collector (lambda (mdv)
+ (eko ("kidnos")(when (numberp mdv)
+ (loop for kn from 1 to (floor mdv)
+ collecting kn))))
+ :value (c-in 5)
+ :kv-key #'value
+ :kid-factory (lambda (f kv)
+ (incf kf-calls)
+ (trc "making kid" kv)
+ (make-instance 'bottle
+ :fm-parent f
+ :value kv
+ :label (c? (format nil "bottle ~d out of ~d on the wall"
+ (^value)
+ (length (kids f)))))))))
+ (ct-assert (eql 5 kf-calls))
+
+ (setq kf-calls 0)
+ (decf (value wall))
+ (ct-assert (eql 4 (length (kids wall))))
+ (ct-assert (zerop kf-calls))
+
+ (setq kf-calls 0)
+ (incf (value wall))
+ (ct-assert (eql 5 (length (kids wall))))
+ (ct-assert (eql 1 kf-calls))
+
+ ))
+
+#+(or)
+(cv-family-values)
Added: dependencies/trunk/cells/cells-test/test-kid-slotting.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test-kid-slotting.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,84 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defmd image (family) left top width height)
+
+(defun i-right (x) (+ (left x) (width x)))
+(defun i-bottom (x) (+ (top x) (height x)))
+
+(defmd stack (image)
+ justify
+ (.kid-slots :initform (lambda (self)
+ (declare (ignore self))
+ (list
+ (mk-kid-slot (left :if-missing t)
+ (c? (+ (left .parent)
+ (ecase (justify .parent)
+ (:left 0)
+ (:center (floor (- (width .parent) (^width)) 2))
+ (:right (- (width .parent) (^width)))))))
+ (mk-kid-slot (top)
+ (c? (bif (psib (psib))
+ (i-bottom psib)
+ (top .parent))))))
+ :accessor kid-slots
+ :initarg :kid-slots))
+;;
+;; kid-slotting exists largely so graphical containers can be defined which arrange their
+;; component parts without those parts' cooperation. so a stack class can be defined as shown
+;; and then arbitrary components thrown in as children and they will be, say, right-justified
+;; because they will be endowed with rules as necessary to achieve that end by the parent stack.
+;;
+;; note the ifmissing option, which defaults to nil. the stack's goal is mainly to manage the
+;; top attribute of each kid to match any predecessor's i-bottom attribute. the stack will as a
+;; a convenience arrange for horizontal justification, but if some kid chose to define its
+;; left attribute that would be honored.
+;;
+(def-cell-test cv-kid-slotting ()
+ (cells-reset)
+ (let ((stack (make-instance 'stack
+ :left 10 :top 20
+ :width 500 :height 1000
+ :justify (c-in :left)
+ :kids (c? (eko ("kids") (loop for kn from 1 to 4
+ collect (make-kid 'image
+ :top 0 ;; overridden
+ :width (* kn 10)
+ :height (* kn 50)))))
+ )))
+ (ct-assert (eql (length (kids stack)) 4))
+ (ct-assert (and (eql 10 (left stack))
+ (every (lambda (k) (eql 10 (left k)))
+ (kids stack))))
+ (ct-assert (every (lambda (k)
+ (eql (top k) (i-bottom (fm-prior-sib k))))
+ (cdr (kids stack))))
+
+ (setf (justify stack) :right)
+ (ct-assert (and (eql 510 (i-right stack))
+ (every (lambda (k) (eql 510 (i-right k)))
+ (kids stack))))
+ ))
Added: dependencies/trunk/cells/cells-test/test-lazy.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test-lazy.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,141 @@
+(in-package :cells)
+
+(defvar *tests* ())
+
+
+(defmacro deftest (name form &rest values)
+ "Po man's RT."
+ (let ((test-name (intern (format nil "TEST ~A" name))))
+ `(progn
+ (defun ,test-name ()
+ (let ((name ',name)
+ (form ',form)
+ (expected-values ',values)
+ (actual-values (multiple-value-list
+ (handler-case ,form
+ (error (val) val)))))
+ (assert (equal actual-values ',values) (actual-values)
+ "Test ~S failed~% ~
+ Form: ~A~% ~
+ Expected values: ~{~S~^; ~}~% ~
+ Actual values: ~{~S~^; ~}"
+ name form expected-values actual-values)
+ ',name))
+ (pushnew ',name *tests*)
+ ',name)))
+
+(defun do-test (name)
+ (let ((test (intern (format nil "TEST ~A" name) (symbol-package name))))
+ (funcall test)))
+
+(defun cv-test-lazy ()
+ (every #'do-test (reverse *tests*)))
+
+(defmacro unbound-error-p (form)
+ `(handler-case
+ (progn
+ ;;(print `(checking unbound error ,',form))
+ ,form nil)
+ (unbound-cell () t)))
+
+(defun make-cell-valid (self slot)
+ (setf (c-state (md-slot-cell self slot)) :valid))
+
+(defmodel unbound-values ()
+ ((val1 :initform (c-input ()) :initarg val1 :accessor test-val1)
+ (val2 :initform (c-input ()) :initarg val2 :accessor test-val2)))
+
+(defmodel unbound-formulas (unbound-values)
+ ((formula :initform nil ;; no longer an exception made for unechoed slots re c-awakening
+ :accessor test-formula)
+ (lazy-formula :initform (c-formula (:lazy t)
+ (^test-val1)
+ (^test-val2))
+ :accessor test-lazy-formula)))
+
+(defmodel unbound-formulas2 (unbound-values)
+ ((formula :initform (c? (^test-val1)
+ (^test-val2))
+ :accessor test-formula)
+ (lazy-formula :initform (c-formula (:lazy t)
+ (^test-val1)
+ (^test-val2))
+ :accessor test-lazy-formula)))
+
+(deftest unbound-values
+ (let ((self (make-instance 'unbound-values)))
+ (values (unbound-error-p (test-val1 self))
+ (unbound-error-p (test-val2 self))))
+ t t)
+
+(deftest md-slot-makunbound
+ (let ((self (progn (make-instance 'unbound-values
+ 'val1 (c-in nil) 'val2 (c-in nil)))))
+ (md-slot-makunbound self 'val1)
+ (md-slot-makunbound self 'val2)
+ (values (unbound-error-p (test-val1 self))
+ (unbound-error-p (test-val2 self))))
+ t t)
+
+(deftest formula-depends-on-unbound
+ (let ((obj1 (progn (make-instance 'unbound-formulas)))
+ (obj2 (progn (make-instance 'unbound-formulas))))
+ (values ;(unbound-error-p (test-formula obj1))
+ (unbound-error-p (test-lazy-formula obj1))
+
+ (unbound-error-p (test-lazy-formula obj2))
+ ;(unbound-error-p (test-formula obj2))
+ ))
+ t t)
+
+(deftest unbound-ok-for-unbound-formulas
+ (unbound-error-p
+ (progn (let ((self (progn (make-instance 'unbound-formulas))))
+ (setf (test-val1 self) t
+ (test-val2 self) t))
+ (let ((self (progn (make-instance 'unbound-formulas))))
+ (setf (test-val2 self) t
+ (test-val1 self) t))))
+ nil)
+
+(deftest unbound-errs-for-eager
+ (let ((self (progn (make-instance 'unbound-formulas2
+ 'val1 (c-in 1) 'val2 (c-in 2)))))
+ (values (test-formula self)
+ (unbound-error-p (md-slot-makunbound self 'val1))
+ (unbound-error-p (md-slot-makunbound self 'val2))
+ ))
+ 2 t t
+ )
+
+(deftest unbound-ok-for-unchecked-lazy
+ (let ((self (progn (make-instance 'unbound-formulas
+ 'val1 (c-in 1) 'val2 (c-in 2)))))
+ (values (test-lazy-formula self)
+ (unbound-error-p (md-slot-makunbound self 'val1))
+ (unbound-error-p (md-slot-makunbound self 'val2))))
+ 2 nil nil)
+
+#+(or)
+(cv-test-lazy)
+
+(defparameter *lz1-count* 0)
+
+(defmd lz-simple ()
+ (lz1 (c?_ (incf *lz1-count*)
+ (* 2 (^lz2))))
+ (lz2 (c-in 0)))
+
+(defun lz-test ()
+ (cells-reset)
+ (let ((*lz1-count* 0)
+ (lz (make-instance 'lz-simple)))
+ (assert (zerop *lz1-count*))
+ (incf (lz2 lz))
+ (assert (zerop *lz1-count*))
+ (assert (= (lz1 lz) 2))
+ (assert (= 1 *lz1-count*))
+ lz))
+
+#+test
+(lz-test)
Added: dependencies/trunk/cells/cells-test/test-synapse.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test-synapse.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,122 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defmodel m-syn ()
+ ((m-syn-a :initform nil :initarg :m-syn-a :accessor m-syn-a)
+ (m-syn-b :initform nil :initarg :m-syn-b :accessor m-syn-b)
+ (m-syn-factor :initform nil :initarg :m-syn-factor :accessor m-syn-factor)
+ (m-sens :initform nil :initarg :m-sens :accessor m-sens)
+ (m-plus :initform nil :initarg :m-plus :accessor m-plus)
+ ))
+
+(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)
+ (sens-ct 0)
+ (plus-ct 0)
+ (m (make-instance 'm-syn
+ :m-syn-a (c-in 0)
+ :m-syn-b (c? (incf delta-ct)
+ (trc nil "syn-b rule firing!!!!!!!!!!!!!! new delta-ct:" delta-ct)
+ (eko (nil "syn-b rule returning")
+ (f-delta :syna-1 (:sensitivity 2)
+ (^m-syn-a))))
+ :m-syn-factor (c-in 1)
+ :m-sens (c? (incf sens-ct)
+ (trc nil "m-sens rule firing ~d !!!!!!!!!!!!!!" sens-ct)
+ (* (^m-syn-factor)
+ (f-sensitivity :sensa (3) (^m-syn-a))))
+ :m-plus (c? (incf plus-ct)
+ (trc nil "m-plus rule firing!!!!!!!!!!!!!!" plus-ct)
+ (f-plusp :syna-2 (- 2 (^m-syn-a)))))))
+ (ct-assert (= 1 delta-ct))
+ (ct-assert (= 1 sens-ct))
+ (ct-assert (= 1 plus-ct))
+ (ct-assert (= 0 (m-sens m)))
+ (trc "make-instance verified. about to incf m-syn-a")
+ (incf (m-syn-a m))
+ (ct-assert (= 1 delta-ct))
+ (ct-assert (= 1 sens-ct))
+ (ct-assert (= 1 plus-ct))
+ (ct-assert (= 0 (m-sens m)))
+ (trc "about to incf m-syn-a 2")
+ (incf (m-syn-a m) 2)
+ (trc nil "syn-b now" (m-syn-b m))
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (= 2 sens-ct))
+ (ct-assert (= 2 plus-ct))
+
+ (ct-assert (= 3 (m-sens m)))
+ (trc "about to incf m-syn-a")
+ (incf (m-syn-a m))
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (= 2 sens-ct))
+ (trc "about to incf m-syn-factor")
+ (incf (m-syn-factor m))
+ (ct-assert (= 3 sens-ct))
+ (ct-assert (= (m-sens m) (* (m-syn-factor m) (m-syn-a m))))
+ (trc "about to incf m-syn-a xxx")
+ (incf (m-syn-a m))
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (= 3 sens-ct))
+ (trc "about to incf m-syn-a yyyy")
+ (incf (m-syn-a m))
+ (ct-assert (= 3 delta-ct))
+ (ct-assert (= 4 sens-ct))
+ (ct-assert (= 2 plus-ct))
+ (describe m)
+ (print '(start))))
+
+(defobserver m-syn-a ()
+ (trc "!!! M-SYN-A now =" new-value))
+
+#+(or)
+(m-syn)
+
Added: dependencies/trunk/cells/cells-test/test.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,273 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+#| Synapse Cell Unification Notes
+
+- start by making Cells synapse-y
+
+- make sure outputs show right old and new values
+- make sure outputs fire when they should
+
+- wow: test the Cells II dictates: no output callback sees stale data, no rule
+sees stale data, etc etc
+
+- test a lot of different synapses
+
+- make sure they fire when they should, and do not when they should not
+
+- make sure they survive an evaluation by the caller which does not branch to
+them (ie, does not access them)
+
+- make sure they optimize away
+
+- test with forms which access multiple other cells
+
+- look at direct alteration of a caller
+
+- does SETF honor not propagating, as well as a c-ruled after re-calcing
+
+- do diff unchanged tests such as string-equal work
+
+|#
+
+#| do list
+
+
+-- test drifters (and can they be handled without creating a special
+subclass for them?)
+
+|#
+
+(eval-when (compile load)
+ (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3))))
+
+(in-package :cells)
+
+(defvar *cell-tests* nil)
+
+#+go
+(test-cells)
+
+
+(defun test-cells ()
+ (dribble "/home/alessio/0algebra/cells-test.txt")
+ (progn ;prof:with-profiling (:type :time)
+ (time
+ (progn
+ (loop for test in (reverse *cell-tests*)
+ when t ; (eq 'cv-test-person-5 test)
+ do (cell-test-init test)
+ (funcall test))
+ (print (make-string 40 :initial-element #\*))
+ (print (make-string 40 :initial-element #\*))
+ (print "*** Cells-test successfully completed **")
+ (print (make-string 40 :initial-element #\*))
+ (print (make-string 40 :initial-element #\*)))))
+ ;(prof:show-call-graph)
+ (dribble))
+
+(defun cell-test-init (name)
+ (print (make-string 40 :initial-element #\!))
+ (print `(starting test ,name))
+ (print (make-string 40 :initial-element #\!))
+ (cells-reset))
+
+(defmacro def-cell-test (name &rest body)
+ `(progn
+ (pushnew ',name *cell-tests*)
+ (defun ,name ()
+ (cells-reset)
+ , at body)))
+
+(defmacro ct-assert (form &rest stuff)
+ `(progn
+ (print `(attempting ,',form))
+ (assert ,form () "Error with ~a >> ~a" ',form (list , at stuff))))
+
+;; test huge number of useds by one rule
+
+(defmd m-index (family)
+ :value (c? (bwhen (ks (^kids))
+ ;(trc "chya" (mapcar 'value ks))
+ (apply '+ (mapcar 'value ks)))))
+
+(def-cell-test many-useds
+ (let ((i (make-instance 'm-index)))
+ (loop for n below 100
+ do (push (make-instance 'model
+ :fm-parent i
+ :value (c-in n))
+ (kids i)))
+ (trc "index total" (value i))
+ (ct-assert (= 4950 (value i)))))
+
+#+test
+(many-useds)
+
+(defmd m-null ()
+ (aa :cell nil :initform nil :initarg :aa :accessor aa))
+
+
+(def-cell-test m-null
+ (let ((m (make-instance 'm-null :aa 42)))
+ (ct-assert (= 42 (aa m)))
+ (ct-assert (= 21 (let ((slot 'aa))
+ (funcall (fdefinition `(setf ,slot)) (- (aa m) 21) m))))
+ :okay-m-null))
+
+(defmd m-solo () m-solo-a m-solo-b)
+
+(def-cell-test m-solo
+ (let ((m (make-instance 'm-solo
+ :m-solo-a (c-in 42)
+ :m-solo-b (c? (trc "b fires")(* 2 (^m-solo-a))))))
+ (ct-assert (= 42 (m-solo-a m)))
+ (ct-assert (= 84 (m-solo-b m)))
+ (decf (m-solo-a m))
+ (ct-assert (= 41 (m-solo-a m)))
+ (ct-assert (= 82 (m-solo-b m)))
+ :okay-m-null))
+
+(defmd m-var () m-var-a m-var-b)
+
+(defobserver m-var-b ()
+ (print `(output m-var-b ,self ,new-value ,old-value)))
+
+(def-cell-test m-var
+ (let ((m (make-instance 'm-var :m-var-a (c-in 42) :m-var-b 1951)))
+ (ct-assert (= 42 (m-var-a m)))
+ (ct-assert (= 21 (decf (m-var-a m) 21)))
+ (ct-assert (= 21 (m-var-a m)))
+ :okay-m-var))
+
+(defmd m-var-output ()
+ cbb
+ (aa :cell nil :initform nil :initarg :aa :accessor aa))
+
+(defobserver cbb ()
+ (trc "output cbb" self)
+ (setf (aa self) (- new-value (if old-value-boundp
+ old-value 0))))
+
+(def-cell-test m-var-output
+ (let ((m (make-instance 'm-var-output :cbb (c-in 42))))
+ (ct-assert (eql 42 (cbb m)))
+ (ct-assert (eql 42 (aa m)))
+ (ct-assert (eql 27 (decf (cbb m) 15)))
+ (ct-assert (eql 27 (cbb m)))
+ (ct-assert (eql -15 (aa m)))
+ (list :okay-m-var (aa m))))
+
+(defmd m-var-linearize-setf () ccc ddd)
+
+(defobserver ccc ()
+ (with-integrity (:change)
+ (setf (ddd self) (- new-value (if old-value-boundp
+ old-value 0)))))
+
+(def-cell-test m-var-linearize-setf
+ (let ((m (make-instance 'm-var-linearize-setf
+ :ccc (c-in 42)
+ :ddd (c-in 1951))))
+
+ (ct-assert (= 42 (ccc m)))
+ (ct-assert (= 42 (ddd m)))
+ (ct-assert (= 27 (decf (ccc m) 15)))
+ (ct-assert (= 27 (ccc m)))
+ (ct-assert (= -15 (ddd m)))
+ :okay-m-var))
+
+;;; -------------------------------------------------------
+
+(defmd m-ruled ()
+ eee
+ (fff (c? (floor (^ccc) 2))))
+
+(defobserver eee ()
+ (print `(output> eee ,new-value old ,old-value)))
+
+(defobserver fff ()
+ (print `(output> eee ,new-value old ,old-value)))
+
+(def-cell-test m-ruled
+ (let ((m (make-instance 'm-ruled
+ :eee (c-in 42)
+ :fff (c? (floor (^eee) 2)))))
+ (trc "___Initial TOBE done____________________")
+ (print `(pulse ,*data-pulse-id*))
+ (ct-assert (= 42 (eee m)))
+ (ct-assert (= 21 (fff m)))
+ (ct-assert (= 36 (decf (eee m) 6)))
+ (print `(pulse ,*data-pulse-id*))
+ (ct-assert (= 36 (eee m)))
+ (ct-assert (= 18 (fff m)) m)
+ :okay-m-ruled))
+
+(defmd m-worst-case ()
+ (wc-x (c-input () 2))
+ (wc-a (c? (prog2
+ (trc "Start A")
+ (when (oddp (wc-x self))
+ (wc-c self))
+ (trc "Stop A"))))
+ (wc-c (c? (evenp (wc-x self))))
+ (wc-h (c? (or (wc-c self)(wc-a self)))))
+
+(defun dependency-dump (self)
+ (let ((slot-cells (loop for esd in (class-slots (class-of self))
+ for sn = (slot-definition-name esd)
+ for c = (md-slot-cell self sn)
+ when c
+ collect (cons sn c))))
+ (trc "dependencies of" self)
+ (loop for (sn . c) in slot-cells
+ do (trc "slot" sn :callers (mapcar 'c-slot-name (c-callers c))))))
+
+(def-cell-test m-worst-case
+ (let ((m (make-instance 'm-worst-case)))
+ (dependency-dump m)
+ (trc "___Initial TOBE done____________________")
+ (ct-assert (eql t (wc-c m)))
+ (ct-assert (eql nil (wc-a m)))
+ (ct-assert (eql t (wc-h m)))
+ (dependency-dump m)
+ (ct-assert (eql 3 (incf (wc-x m))))))
+
+(defmd c?n-class ()
+ aaa bbb
+ (sum (c? (+ (^aaa) (^bbb)))))
+
+(def-cell-test test-c?n ()
+ (let ((self (make-instance 'c?n-class
+ :aaa (c?n (+ (^bbb) 2))
+ :bbb (c-in 40))))
+ (ct-assert (= (^bbb) 40)) ;; make sure I have not broken (setf slot-value)...it happens
+ (ct-assert (= (^aaa) 42)) ;; make sure the rule ran and the value stored as the slot value
+ (ct-assert (= (^sum) 82)) ;; make sure a normal rule works off the others
+ (setf (^bbb) 100)
+ (ct-assert (= (^bbb) 100)) ;; just checking
+ (ct-assert (= (^aaa) 42)) ;; make sure the rule did not run again
+ (ct-assert (= (^sum) 142)) ;; ... but the other rule does fire
+ (setf (^aaa) -58)
+ (ct-assert (= (^aaa) -58)) ;; ... we can setf the once-ruled slot
+ (ct-assert (= (^sum) 42)) ;; ... propagation still works from the once-ruled, now-input slot
+ ))
Added: dependencies/trunk/cells/cells-test/test.lpr
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test.lpr Tue Jan 26 15:20:07 2010
@@ -0,0 +1,13 @@
+;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2006 20:04)"; cg: "1.81"; -*-
+
+(in-package :cg-user)
+
+(defpackage :CELLS)
+
+(define-project :name :test
+ :modules (list (make-instance 'module :name "test.lisp")
+ (make-instance 'module :name "test-ephemeral.lisp")
+ (make-instance 'module :name "test-cycle.lisp")
+ (make-instance 'module :name "test-synapse.lisp")
+ (make-instance 'module :name "output-timing.lisp"))
+ :projects (list (make-instance 'project-module :name "..\\cells"))
\ No newline at end of file
Added: dependencies/trunk/cells/cells.asd
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells.asd Tue Jan 26 15:20:07 2010
@@ -0,0 +1,47 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+
+#+(or allegro lispworks cmu mcl clisp cormanlisp sbcl scl abcl)
+(progn
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+
+(asdf:defsystem :cells
+ :name "cells"
+ :author "Kenny Tilton <kentilton at gmail.com>"
+ :maintainer "Kenny Tilton <kentilton at gmail.com>"
+ :licence "Lisp LGPL"
+ :description "Cells"
+ :long-description "Cells: a dataflow extension to CLOS."
+ :version "3.0"
+ :serial t
+ :depends-on (:utils-kt)
+ :components ((:file "defpackage")
+ (:file "trc-eko")
+ (:file "cells")
+ (:file "integrity")
+ (:file "cell-types")
+ (:file "constructors")
+ (:file "initialize")
+ (:file "md-slot-value")
+ (:file "slot-utilities")
+ (:file "link")
+ (:file "propagate")
+ (:file "synapse")
+ (:file "synapse-types")
+ (:file "model-object")
+ (:file "defmodel")
+ (:file "md-utilities")
+ (:file "family")
+ (:file "fm-utilities")
+ (:file "family-values")
+ (:file "test-propagation")
+ (:file "cells-store")
+ (:file "test-cc")))
+
+(defmethod perform ((o load-op) (c (eql (find-system :cells))))
+ (pushnew :cells *features*))
+
+(defmethod perform ((o test-op) (c (eql (find-system :cells))))
+ (oos 'load-op :cells-test))
+
+(defmethod perform ((o test-op) (c (eql :cells)))
+ (oos 'load-op :cells-test)))
Added: dependencies/trunk/cells/cells.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,190 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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.
+
+|#
+
+#| Notes
+
+I don't like the way with-cc defers twice, first the whole thing and then when the
+body finally runs we are still within the original integrity and each setf gets queued
+to UFB separately before md-slot-value-assume finally runs. I think all that is going on here
+is that we want the programmer to use with-cc to show they know the setf will not be returning
+a useful value. But since they have coded the with-cc we should be able to figure out a way to
+let those SETFs thru as if they were outside integrity, and then we get a little less UFBing
+but even better SETF behaves as it should.
+
+It would be nice to do referential integrity and notice any time a model object gets stored in
+a cellular slot (or in a list in such) and then mop those up on not-to-be.
+
+|#
+
+(in-package :cells)
+
+(defparameter *c-prop-depth* 0)
+(defparameter *causation* nil)
+
+(defparameter *data-pulse-id* 0)
+(define-symbol-macro .dpid *data-pulse-id*)
+(defparameter *finbiz-id* 0) ;; debugging tool only
+(define-symbol-macro .fbid *finbiz-id*)
+
+(export! .dpid .fbid)
+(defparameter *c-debug* nil)
+(defparameter *defer-changes* nil)
+(defparameter *within-integrity* nil)
+(defvar *istack*)
+(defparameter *client-queue-handler* nil)
+(defparameter *unfinished-business* nil)
+(defparameter *not-to-be* nil)
+
+(defparameter *awake* nil)
+(defparameter *awake-ct* nil)
+
+#+test
+(cells-reset)
+
+(defun cells-reset (&optional client-queue-handler &key debug)
+ (utils-kt-reset)
+ (setf
+ *c-debug* debug
+ *c-prop-depth* 0
+ *awake-ct* nil
+ *awake* nil
+ *not-to-be* nil
+ *data-pulse-id* 0
+ *finbiz-id* 0
+ *defer-changes* nil ;; should not be necessary, but cannot be wrong
+ *client-queue-handler* client-queue-handler
+ *within-integrity* nil
+ *unfinished-business* nil
+ *trcdepth* 0)
+ (trc nil "------ cell reset ----------------------------"))
+
+(defun c-stop (&optional why)
+ (setf *stop* t)
+ (print `(c-stop-entry ,why))
+ (format t "~&C-STOP> stopping because ~a" why) )
+
+(define-symbol-macro .stop
+ (c-stop :user))
+
+(defun c-stopped ()
+ *stop*)
+
+(export! .stopped .cdbg)
+
+(define-symbol-macro .cdbg
+ *c-debug*)
+
+(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)
+ `(unless *stop*
+ (unless ,assertion
+ ,(if fmt$
+ `(c-break ,fmt$ , at fmt-args)
+ `(c-break "failed assertion: ~a" ',assertion)))))
+
+(defvar *call-stack* nil)
+(defvar *depender* nil)
+;; 2008-03-15: *depender* let's us differentiate between the call stack and
+;; and dependency. The problem with overloading *call-stack* with both roles
+;; is that we miss cyclic reentrance when we use without-c-dependency in a
+;; rule to get "once" behavior or just when fm-traversing to find someone
+
+(defmacro def-c-trace (model-type &optional slot cell-type)
+ `(defmethod trcp ((self ,(case cell-type
+ (:c? 'c-dependent)
+ (otherwise 'cell))))
+ (and (typep (c-model self) ',model-type)
+ ,(if slot
+ `(eq (c-slot-name self) ',slot)
+ `t))))
+
+(defmacro without-c-dependency (&body body)
+ ` (let (*depender*)
+ , at body))
+
+(export! .cause)
+
+(define-symbol-macro .cause
+ (car *causation*))
+
+(define-condition unbound-cell (unbound-slot)
+ ((cell :initarg :cell :reader cell :initform nil)))
+
+(defgeneric slot-value-observe (slotname self new old old-boundp cell)
+ #-(or cormanlisp)
+ (:method-combination progn))
+
+#-cells-testing
+(defmethod slot-value-observe #-(or cormanlisp) progn
+ (slot-name self new old old-boundp cell)
+ (declare (ignorable slot-name self new old old-boundp cell)))
+
+#+hunh
+(fmakunbound 'slot-value-observe)
+; -------- cell conditions (not much used) ---------------------------------------------
+
+(define-condition xcell () ;; new 2k0227
+ ((cell :initarg :cell :reader cell :initform nil)
+ (app-func :initarg :app-func :reader app-func :initform 'bad-cell)
+ (error-text :initarg :error-text :reader error-text :initform "<???>")
+ (other-data :initarg :other-data :reader other-data :initform "<nootherdata>"))
+ (:report (lambda (c s)
+ (format s "~& trouble with cell ~a in function ~s,~s: ~s"
+ (cell c) (app-func c) (error-text c) (other-data c)))))
+
+(define-condition c-enabling ()
+ ((name :initarg :name :reader name)
+ (model :initarg :model :reader model)
+ (cell :initarg :cell :reader cell))
+ (:report (lambda (condition stream)
+ (format stream "~&unhandled <c-enabling>: ~s" condition)
+ (break "~&i say, unhandled <c-enabling>: ~s" condition))))
+
+(define-condition c-fatal (xcell)
+ ((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 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 :c-break)
+ ;(format t "~&c-break > stopping > ~{~a ~}" args2)
+ (apply 'error args2))))
\ No newline at end of file
Added: dependencies/trunk/cells/cells.lpr
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells.lpr Tue Jan 26 15:20:07 2010
@@ -0,0 +1,57 @@
+;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*-
+
+(in-package :cg-user)
+
+(defpackage :CELLS)
+
+(define-project :name :cells
+ :modules (list (make-instance 'module :name "defpackage.lisp")
+ (make-instance 'module :name "trc-eko.lisp")
+ (make-instance 'module :name "cells.lisp")
+ (make-instance 'module :name "integrity.lisp")
+ (make-instance 'module :name "cell-types.lisp")
+ (make-instance 'module :name "constructors.lisp")
+ (make-instance 'module :name "initialize.lisp")
+ (make-instance 'module :name "md-slot-value.lisp")
+ (make-instance 'module :name "slot-utilities.lisp")
+ (make-instance 'module :name "link.lisp")
+ (make-instance 'module :name "propagate.lisp")
+ (make-instance 'module :name "synapse.lisp")
+ (make-instance 'module :name "synapse-types.lisp")
+ (make-instance 'module :name "model-object.lisp")
+ (make-instance 'module :name "defmodel.lisp")
+ (make-instance 'module :name "md-utilities.lisp")
+ (make-instance 'module :name "family.lisp")
+ (make-instance 'module :name "fm-utilities.lisp")
+ (make-instance 'module :name "family-values.lisp")
+ (make-instance 'module :name "test-propagation.lisp")
+ (make-instance 'module :name "cells-store.lisp")
+ (make-instance 'module :name "test-cc.lisp"))
+ :projects (list (make-instance 'project-module :name
+ "utils-kt\\utils-kt" :show-modules
+ nil))
+ :libraries nil
+ :distributed-files nil
+ :internally-loaded-files nil
+ :project-package-name :cells
+ :main-form nil
+ :compilation-unit t
+ :verbose nil
+ :runtime-modules nil
+ :splash-file-module (make-instance 'build-module :name "")
+ :icon-file-module (make-instance 'build-module :name "")
+ :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 (list :read-init-files nil)
+ :old-space-size 256000
+ :new-space-size 6144
+ :runtime-build-option :standard
+ :build-number 0
+ :on-initialization 'cells::test-with-cc
+ :on-restart 'do-default-restart)
+
+;; End of Project Definition
Added: dependencies/trunk/cells/constructors.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/constructors.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,219 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+(eval-now!
+ (export '(.cache-bound-p
+
+ ;; Cells Constructors
+ c?n
+ c?once
+ c?n-until
+ c?1
+ c_1
+ c?+n
+
+ ;; Debug Macros and Functions
+ c?dbg
+ c_?dbg
+ c-input-dbg
+
+ )))
+
+;___________________ constructors _______________________________
+
+(defmacro c-lambda (&body body)
+ `(c-lambda-var (slot-c) , at body))
+
+(defmacro c-lambda-var ((c) &body body)
+ `(lambda (,c &aux (self (c-model ,c))
+ (.cache (c-value ,c))
+ (.cache-bound-p (cache-bound-p ,c)))
+ (declare (ignorable .cache .cache-bound-p self))
+ , at body))
+
+(defmacro with-c-cache ((fn) &body body)
+ (let ((new (gensym)))
+ `(or (bwhen (,new (progn , at body))
+ (funcall ,fn ,new .cache))
+ .cache)))
+
+;-----------------------------------------
+
+(defmacro c? (&body body)
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! ',body
+ :value-state :unevaluated
+ :rule (c-lambda , at body)))
+
+(defmacro c?+n (&body body)
+ `(make-c-dependent
+ :inputp t
+ :code #+its-alive! nil #-its-alive! ',body
+ :value-state :unevaluated
+ :rule (c-lambda , at body)))
+
+(defmacro c?n (&body body)
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! '(without-c-dependency , at body)
+ :inputp t
+ :value-state :unevaluated
+ :rule (c-lambda (without-c-dependency , at body))))
+
+(export! c?n-dbg)
+
+(defmacro c?n-dbg (&body body)
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! '(without-c-dependency , at body)
+ :inputp t
+ :debug t
+ :value-state :unevaluated
+ :rule (c-lambda (without-c-dependency , at body))))
+
+(defmacro c?n-until (args &body body)
+ `(make-c-dependent
+ :optimize :when-value-t
+ :code #+its-alive! nil #-its-alive! ',body
+ :inputp t
+ :value-state :unevaluated
+ :rule (c-lambda , at body)
+ , at args))
+
+(defmacro c?once (&body body)
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! '(without-c-dependency , at body)
+ :inputp nil
+ :value-state :unevaluated
+ :rule (c-lambda (without-c-dependency , at body))))
+
+(defmacro c_1 (&body body)
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! '(without-c-dependency , at body)
+ :inputp nil
+ :lazy t
+ :value-state :unevaluated
+ :rule (c-lambda (without-c-dependency , at body))))
+
+(defmacro c?1 (&body body)
+ `(c?once , at body))
+
+(defmacro c?dbg (&body body)
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! ',body
+ :value-state :unevaluated
+ :debug t
+ :rule (c-lambda , at body)))
+
+(defmacro c?_ (&body body)
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! ',body
+ :value-state :unevaluated
+ :lazy t
+ :rule (c-lambda , at body)))
+
+(defmacro c_? (&body body)
+ "Lazy until asked, then eagerly propagating"
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! ',body
+ :value-state :unevaluated
+ :lazy :until-asked
+ :rule (c-lambda , at body)))
+
+(defmacro c_?dbg (&body body)
+ "Lazy until asked, then eagerly propagating"
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! ',body
+ :value-state :unevaluated
+ :lazy :until-asked
+ :rule (c-lambda , at body)
+ :debug t))
+
+(defmacro c?? ((&key (tagp nil) (in nil) (out t))&body body)
+ (let ((result (copy-symbol 'result))
+ (thetag (gensym)))
+ `(make-c-dependent
+ :code ',body
+ :value-state :unevaluated
+ :rule (c-lambda
+ (let ((,thetag (gensym "tag"))
+ (*trcdepth* (1+ *trcdepth*))
+ )
+ (declare (ignorable self ,thetag))
+ ,(when in
+ `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag)))
+ (count-it :c?? (c-slot-name c) (md-name (c-model c)))
+ (let ((,result (progn , at body)))
+ ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag)))
+ ,result))))))
+
+(defmacro c-formula ((&rest keys &key lazy &allow-other-keys) &body forms)
+ (assert (member lazy '(nil t :once-asked :until-asked :always)))
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! ',forms
+ :value-state :unevaluated
+ :rule (c-lambda , at forms)
+ , at keys))
+
+(defmacro c-input ((&rest keys) &optional (value nil valued-p))
+ `(make-cell
+ :inputp t
+ :value-state ,(if valued-p :valid :unbound)
+ :value ,value
+ , at keys))
+
+(defmacro c-in (value)
+ `(make-cell
+ :inputp t
+ :value-state :valid
+ :value ,value))
+
+(export! c-in-lazy c_in)
+
+(defmacro c-in-lazy (&body body)
+ `(c-input (:lazy :once-asked) (progn , at body)))
+
+(defmacro c_in (&body body)
+ `(c-input (:lazy :once-asked) (progn , at body)))
+
+(defmacro c-input-dbg (&optional (value nil valued-p))
+ `(make-cell
+ :inputp t
+ :debug t
+ :value-state ,(if valued-p :valid :unbound)
+ :value ,value))
+
+(defmacro c... ((value) &body body)
+ `(make-c-drifter
+ :code ',body
+ :value-state :valid
+ :value ,value
+ :rule (c-lambda , at body)))
+
+(defmacro c-abs (value &body body)
+ `(make-c-drifter-absolute
+ :code ',body
+ :value-state :valid
+ :value ,value
+ :rule (c-lambda , at body)))
+
+
+(defmacro c-envalue (&body body)
+ `(make-c-envaluer
+ :envalue-rule (c-lambda , at body)))
+
Added: dependencies/trunk/cells/defmodel.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/defmodel.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,207 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :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)
+ `(progn
+ (setf (get ',class :cell-types) nil)
+ (setf (get ',class 'slots-excluded-from-persistence)
+ (loop for slotspec in ',slotspecs
+ unless (and (getf (cdr slotspec) :ps t)
+ (getf (cdr slotspec) :persistable t))
+ collect (car slotspec)))
+ (loop for slotspec in ',slotspecs
+ do (destructuring-bind
+ (slotname &rest slotargs
+ &key (cell t)
+ &allow-other-keys)
+ slotspec
+ (declare (ignorable slotargs))
+ (when cell
+ (setf (md-slot-cell-type ',class slotname) cell))))
+ ;; define slot macros before class so they can appear in
+ ;; initforms and default-initargs
+ ,@(loop for slotspec in slotspecs
+ nconcing (destructuring-bind
+ (slotname &rest slotargs
+ &key (cell t) (accessor slotname) reader
+ &allow-other-keys)
+ slotspec
+ (declare (ignorable slotargs ))
+ (when cell
+ (list (let* ((reader-fn (or reader accessor))
+ (deriver-fn (intern$ "^" (symbol-name reader-fn))))
+ `(eval-when (:compile-toplevel :execute :load-toplevel)
+ (unless (macro-function ',deriver-fn)
+ (defmacro ,deriver-fn ()
+ `(,',reader-fn self)))
+ #+sbcl (unless (fboundp ',reader-fn)
+ (defgeneric ,reader-fn (slot)))))))))
+
+ ;
+ ; ------- defclass --------------- (^slot-value ,model ',',slotname)
+ ;
+ (prog1
+ (defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class
+ ,(mapcar (lambda (s)
+ (list* (car s)
+ (let ((ias (cdr s)))
+ (remf ias :persistable)
+ (remf ias :ps)
+ ;; We handle accessor below
+ (when (getf ias :cell t)
+ (remf ias :reader)
+ (remf ias :writer)
+ (remf ias :accessor))
+ (remf ias :cell)
+ (remf ias :owning)
+ (remf ias :unchanged-if)
+ ias))) (mapcar #'copy-list slotspecs))
+ (:documentation
+ ,@(or (cdr (find :documentation options :key #'car))
+ '("chya")))
+ (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
+ ,@(cdr (find :default-initargs options :key #'car)))
+ (:metaclass ,(or (cadr (find :metaclass options :key #'car))
+ 'standard-class)))
+
+ (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key)
+ (declare (ignore slot-names iargs))
+ ,(when (and directsupers (not (member 'model-object directsupers)))
+ `(unless (typep self 'model-object)
+ (error "If no superclass of ~a inherits directly
+or indirectly from model-object, model-object must be included as a direct super-class in
+the defmodel form for ~a" ',class ',class))))
+
+ ;
+ ; slot accessors once class is defined...
+ ;
+ ,@(mapcar (lambda (slotspec)
+ (destructuring-bind
+ (slotname &rest slotargs
+ &key (cell t) unchanged-if (accessor slotname) reader writer type
+ &allow-other-keys)
+ slotspec
+
+ (declare (ignorable slotargs))
+ (when cell
+ (let* ((reader-fn (or reader accessor))
+ (writer-fn (or writer accessor))
+ )
+ `(progn
+ ,(when writer-fn
+ `(defmethod (setf ,writer-fn) (new-value (self ,class))
+ (setf (md-slot-value self ',slotname)
+ ,(if type
+ `(coerce new-value ',type)
+ 'new-value))))
+ ,(when reader-fn
+ `(defmethod ,reader-fn ((self ,class))
+ (md-slot-value self ',slotname)))
+ ,(when unchanged-if
+ `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)))))))
+ slotspecs))
+ (loop for slotspec in ',slotspecs
+ do (destructuring-bind
+ (slotname &rest slotargs &key (cell t) owning &allow-other-keys)
+ slotspec
+ (declare (ignorable slotargs))
+ (when (and cell owning)
+ (setf (md-slot-owning-direct? ',class slotname) owning))))))
+
+(defun defmd-canonicalize-slot (slotname
+ &key
+ (cell nil cell-p)
+ (ps t ps-p)
+ (persistable t persistable-p)
+ (owning nil owning-p)
+ (type nil type-p)
+ (initform nil initform-p)
+ (initarg (intern (symbol-name slotname) :keyword))
+ (documentation nil documentation-p)
+ (unchanged-if nil unchanged-if-p)
+ (reader slotname reader-p)
+ (writer `(setf ,slotname) writer-p)
+ (accessor slotname accessor-p)
+ (allocation nil allocation-p))
+ (list* slotname :initarg initarg
+ (append
+ (when cell-p (list :cell cell))
+ (when ps-p (list :ps ps))
+ (when persistable-p (list :persistable persistable))
+ (when owning-p (list :owning owning))
+ (when type-p (list :type type))
+ (when initform-p (list :initform initform))
+ (when unchanged-if-p (list :unchanged-if unchanged-if))
+ (when reader-p (list :reader reader))
+ (when writer-p (list :writer writer))
+ (when (or accessor-p
+ (not (and reader-p writer-p)))
+ (list :accessor accessor))
+ (when allocation-p (list :allocation allocation))
+ (when documentation-p (list :documentation documentation)))))
+
+(defmacro defmd (class superclasses &rest mdspec)
+ `(defmodel ,class (, at superclasses model)
+ ,@(let (definitargs class-options slots)
+ (loop with skip
+ for (spec next) on mdspec
+ if skip
+ do (setf skip nil)
+ else do (etypecase spec
+ (cons
+ (cond
+ ((keywordp (car spec))
+ (assert (find (car spec) '(:documentation :metaclass)))
+ (push spec class-options))
+ ((find (cadr spec) '(:initarg :type :ps :persistable :cell :initform :allocation :reader :writer :accessor :documentation))
+ (push (apply 'defmd-canonicalize-slot spec) slots))
+ (t ;; shortform (slotname initform &rest slotdef-key-values)
+ (push (apply 'defmd-canonicalize-slot
+ (list* (car spec) :initform (cadr spec) (cddr spec))) slots))))
+ (keyword
+ (setf definitargs (append definitargs (list spec next)))
+ (setf skip t))
+ (symbol (push (list spec :initform nil
+ :initarg (intern (symbol-name spec) :keyword)
+ :accessor spec) slots)))
+ finally
+ (return (list* (nreverse slots)
+ (delete nil
+ (list* `(:default-initargs , at definitargs)
+ (nreverse class-options)))))))))
+
+
+
+#+test
+(progn
+ (defclass md-test-super ()())
+
+ (defmd defmd-test (md-test-super)
+ (aaa :cell nil :initform nil :initarg :aaa :accessor aaa) ;; defmd would have written the same
+ (aa2 :documentation "hi mom")
+ bbb
+ (ccc 42 :allocation :class)
+ (ddd (c-in nil) :cell :ephemeral)
+ :superx 42 ;; default-initarg
+ (:documentation "as if!")))
+
+
+
Added: dependencies/trunk/cells/defpackage.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/defpackage.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,64 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 2008 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :common-lisp-user)
+
+(defpackage :cells
+ (:use #:common-lisp #:utils-kt #+abcl #:sys)
+ (:import-from
+ ;; MOP
+ #+allegro #:excl
+ #+clisp #:clos
+ #+cmu #:mop
+ #+cormanlisp #:common-lisp
+ #+lispworks #:clos
+ #+sbcl #:sb-mop
+ #+openmcl-partial-mop #:openmcl-mop
+ #+(and mcl (not openmcl-partial-mop)) #:ccl
+ #+abcl #:mop
+ #-(or allegro clisp cmu cormanlisp lispworks mcl sbcl abcl)
+ #.(cerror "Provide a package name."
+ "Don't know how to find the MOP package for this Lisp.")
+
+ #:class-precedence-list
+ #-(and mcl (not openmcl-partial-mop)) #:class-slots
+ #:slot-definition-name
+ #:class-direct-subclasses
+ )
+ (:export #:cell #:.md-name
+ #:c-input #:c-in #:c-in8
+ #:c-formula #:c? #:c_? #:c?8 #:c?_ #:c??
+ #:with-integrity #:without-c-dependency #:self #:*parent*
+ #:.cache #:.with-c-cache #:c-lambda
+ #:defmodel #:defmd #:defobserver #:slot-value-observe #:def-c-unchanged-test
+ #:new-value #:old-value #:old-value-boundp #:c...
+ #:md-awaken
+ #:mkpart #:make-kid #:the-kids #:nsib #:value #:^value #:.value #:kids #:^kids #:.kids
+ #:cells-reset #:upper #:fm-max #:nearest #:fm-min-kid #:fm-max-kid #:mk-kid-slot
+ #:def-kid-slots #:find-prior #:fm-pos #:kid-no #:fm-includes #:fm-ascendant-common
+ #: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)
+ )
+
Added: dependencies/trunk/cells/doc/01-Cell-basics.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/doc/01-Cell-basics.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,431 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+#|
+
+[A minimal primer on cells, last tested on march 13, 2006 against cells3]
+
+cells
+-----
+think of a clos slot as a cell in a paper spreadsheet, a financial
+modeling tool popular enough to make visi-calc the first business
+killer app for microcomputers.
+
+as a child i watched my father toil at home for hours over paper
+spreadsheets with pencil and slide rule. after he changed one value,
+he had to propagate that change to other cells by first remembering
+which other ones included the changed cell in their computation.
+then he had to do the calculations for those, erase, enter...
+and then repeating that process to propagate those changes in a
+cascade across the paper.
+
+visi-calc let my father take the formula he had in mind and
+put it in (declare it to) the electronic spreadsheet. then visi-calc
+could do the tedious work: recalculating, knowing what to recalculate,
+and knowing in what order to recalculate.
+
+cells do for programmers what electronic spreadsheets did for my father.
+without cells, clos slots are like cells of a paper spreadsheet.
+a single key-down event can cause a cascade of change throughout an
+application. the programmer has to arrange for it all to happen,
+all in the right order: delete any selected text, insert
+the new character, re-wrap the text, update the undo mechanism, revisit
+the menu statuses ("cut" is no longer enabled), update the scroll bars,
+possibly scroll the window, flag the file as unsaved...
+
+with cells, the programmer looks at program state differently. one
+asks, "how could i compute, at any point of runtime, a value for
+a given slot of an arbitrary instance, based only on other runtime state
+(other slots of other instances)." great fun, by the way, as well as
+enforcing good programming practices like encapsulation.
+
+an example will help. consider indeed the state of the "cut" menu item.
+in some applications, programmers have a dozen places in their code
+where they tend to the status of the cut menu item. one might be:
+
+(defun do-clear (edit-structure)
+ (when (selected-range edit-structure)
+ <set up undo>
+ <toss selected text>
+ <etc><etc>
+ (menu-item-enable *edit-cut* nil)
+ (menu-item-enable *edit-copy* nil)
+ (menu-item-enable *edit-clear* nil)))
+
+other programmers wait until the user clicks on the edit menu,
+then decide just-in-time from program state whether the cut item
+should be enabled:
+
+(defmethod prep-for-display ((m edit-menu))
+ <lotsa other stuff>
+ (when (typep (focus *app*) 'text-edit-widget)
+ (menu-item-enable (find :cut (items m) :key #'item-name)
+ (not (null (selected-range (focus *app*)))))))
+
+this latter programmer is ready for cells, because they
+have already shifted from imperative to declarative thinking;
+they have learned to write code that works based not on what
+has happened lately, but instead only on the current program
+state (however it got that way).
+
+the cell programmer writes:
+
+(make-instance 'menu-item
+ :name :cut
+ :label "cut"
+ :cmd-key +control-x+
+ :actor #'do-cut
+ :enabled (c? (when (typep (focus *app*) 'text-edit-widget)
+ (not (null (selected-range (focus *app*)))))))
+
+...and now they can forget the menu item exists as they work
+on the rest of the application. the menu-item enabled status
+will stay current (correct) as the selected-range changes
+and as the focus itself changes as the user moves from field
+to field.
+
+that covers the spirit of cells. now let's look at the syntax
+and mechanics, with examples you can execute once you have
+loaded the cells package. see the read-me.txt file in the
+root directory into which the cello software was unzipped.
+
+we'll model a falling stone, where the distance fallen is half
+the product of the acceleration (due to gravity) and the
+square of the time falling.
+
+|#
+
+(in-package :cells)
+
+(defmodel stone ()
+ ((accel :cell t :initarg :accel :initform 0 :accessor accel)
+ (time-elapsed :cell t :initarg :time-elapsed
+ :initform (c-in 0)
+ :accessor time-elapsed)
+ (distance :cell t :initarg :distance :initform 0 :accessor distance))
+ (:default-initargs
+ :distance (c? (/ (* (accel self)
+ (expt (time-elapsed self) 2))
+ 2))))
+
+(defobserver accel ((self stone) new old old-bound-p)
+ (trc "observer sees accel" :new new :old old :oldp old-bound-p)) ;; TRC provides print diagnostics
+
+(defobserver time-elapsed ((self stone)) ;; short form (I'm lazy)
+ (trc "observer sees time-elapsed" :new new-value :old old-value :oldp old-value-boundp))
+
+(defobserver distance ((self stone))
+ (format t "~&observer sees distance fallen: ~d feet" new-value))
+
+
+#|
+let's look at non-standard syntax found in the forms above,
+in the order in which they appear:
+
+ (defmodel ...
+
+defmodel is just a defclass wrapper which also sets up plumbing for cells.
+
+ ... :cell t ...
+
+without this option, a model instance slot cannot be powered
+by a cell (and cell slot access overhead is avoided).
+
+with this option, one can specify what kind of cell
+is to be defined: ephemeral, delta or t (normal). we'll leave
+those esoteric cell slot types for another tutorial and just
+specify t to get normal cells (the ones used 99% of the time).
+
+ time-elapsed ... :initform (c-in 0)...
+
+(c-in <value>) allows the cellular slot (or "cell", for short)
+to be setf'ed. these are inputs to the dataflow,
+which usually flows from c? to c? but has to start somewhere.
+since modern interactve applications are event-driven, in
+real-world cello apps most cv dataflow inputs are slots closely
+corresponding to some system value, such as the position slots
+of a cell-powered mouse class. moving on...
+
+a naked value such as the 32 supplied for accel cannot be changed; a
+runtime error results from any such attempt. this makes cells faster,
+because some plumbing can be skipped: no dependency gets recorded between
+the distance traveled and the acceleration. on the other hand, a more
+elaborate model might have the acceleration varying according to the distance
+between the stone and earth (in which case we get into an advance
+topic for another day, namely how to handle circularity.)
+
+next: (:default-initargs
+ :distance (c? (/ (* (accel self)
+ (expt (time-elapsed self) 2))
+ 2)
+
+c? associates a rule with a cellular slot (or "cell", for short). any
+read operation on another cell (directly or during a function call)
+establishes a dependency of distance on that cell -- unless that cell
+can never change. why would a cell not be able to change?
+
+cell internals enforce a rule that a cell with a naked value (ie, not wrapped
+in cv or c?) cannot be changed by client code (ok, (setf slot-value) is a backdoor).
+cell internals enforce this, simply to make possible the optimization
+of leaving off the overhead of recording a pointless dependency.
+
+next: (defobserver...
+
+here is the signature for the defobserver macro:
+
+ (defmacro defobserver (slotname (&optional (self-arg 'self)
+ (new-varg 'new-value)
+ (oldvarg 'old-value)
+ (oldvargboundp 'old-value-boundp))
+ &body observer-body) ....)
+
+defobserver defines a generic method with method-combination progn,
+which one can specialize on any of the four
+parameters. the method gets called when the slot value changes, and during
+initial processing by shared-initialize (part of make-instance).
+
+shared-initialize brings a new model instance to life, including calling
+any observers defined for cellular slots.
+
+now evaluate the following:
+
+|#
+
+#+evaluatethis
+
+(progn
+ (cells-reset)
+ (defparameter *s2* (make-instance 'stone
+ :accel 32 ;; (constant) feet per second per second
+ :time-elapsed (c-in 0))))
+
+#|
+
+...and observe:
+0> observer sees accel :new 32 :old nil :oldp nil
+0> observer sees time-elapsed :new 0 :old nil :oldp nil
+observer sees distance fallen: 0 feet
+
+
+getting back to the output shown above, why observer output on a new instance? we want
+any new instance to come fully to life. that means
+evaluating every rule so the dependencies get established, and
+propagating cell values outside the model (by calling the observer
+methods) to make sure the model and outside world (if only the
+system display) are consistent.
+
+;-----------------------------------------------------------
+now let's get moving:
+
+|#
+
+#+evaluatethis
+
+(setf (time-elapsed *s2*) 1)
+
+#|
+...and observe:
+0> observer sees time-elapsed :new 1 :old 0 :oldp t
+observer sees distance fallen: 16 feet
+
+behind the scenes:
+- the slot value time-elapsed got changed from 0 to 1
+- the time-elapsed observer was called
+- dependents on time-elapsed (here just distance) were recalculated
+- go to the first step, this time for the distance slot
+
+;-----------------------------------------------------------
+to see some optimizations at work, set the cell time-elapsed to
+the same value it already has:
+|#
+
+#+evaluatethis
+
+(setf (time-elapsed *s2*) 1)
+
+#| observe:
+nothing, since the slot-value did not in fact change.
+
+;-----------------------------------------------------------
+to test the enforcement of the cell stricture against
+modifying cells holding naked values:
+|#
+
+#+evaluatethis
+
+(let ((*c-debug* t))
+ (handler-case
+ (setf (accel *s2*) 10)
+ (t (error)
+ (cells-reset) ;; clear a *stop* flag used to bring down a runaway model :)
+ (trc "error is" error)
+ error)))
+
+#| observe:
+c-setting-debug > constant accel in stone may not be altered..init to (c-in nil)
+0> error is #<simple-error @ #x210925f2>
+
+Without turning on *c-debug* one just gets the runtime error, not the explanation to standard output.
+
+;-----------------------------------------------------------
+nor may ruled cells be modified arbitrarily:
+|#
+
+#+evaluatethis
+
+(let ((*c-debug* t))
+ (handler-case
+ (setf (distance *s2*) 42)
+ (t (error)
+ (cells-reset)
+ (trc "error is" error)
+ error)))
+
+#| observe:
+c-setting-debug > ruled distance in stone may not be setf'ed
+0> error is #<simple-error @ #x2123e392>
+
+;-----------------------------------------------------------
+aside from c?, cv, and defobserver, another thing you will see
+in cello code is how complex views are constructed using
+the family class and its slot kids. every model-object has a
+parent slot, which gets used along with a family's kids slot to
+form simple trees navigable up and down.
+
+model-objects also have slots for md-name and value (don't
+worry camelcase-haters, that is a declining feature of my code).
+md-name lets the family trees we build be treated as namespaces.
+value just turns out to be very handy for a lot of things. for
+example, a check-box instance needs some place to indicate its
+boolean state.
+
+now let's see family in action, using code from the handbook of
+silly examples. all i want to get across is that a lot happens
+when one changes the kids slot. it happens automatically, and
+it happens transparently, following the dataflow implicit in the
+rules we write, and the side-effects we specify via observer functions.
+
+the silly example below just shows the summer (that which sums) getting
+a new value as the kids change, along with some observer output. in real-world
+applications, where kids represent gui elements often dependent on
+each other, vastly more can transpire before a simple push into a kids
+slot has run its course.
+
+evaluate:
+|#
+
+(defmodel summer (family)
+ ()
+ (:default-initargs
+ :kids (c-in nil) ;; or we cannot add any addend kids later
+ :value (c? (trc "val rule runs")
+ (reduce #'+ (kids self)
+ :initial-value 0
+ :key #'value))))
+
+(defobserver .value ((self summer))
+ (trc "the sum of the values of the kids is" new-value))
+
+(defobserver .kids ((self summer))
+ (trc "the values of the kids are" (mapcar #'value new-value)))
+
+;-----------------------------------------------------------
+; now just evaluate each of the following forms one by one,
+; checking results after each to see what is going on
+;
+#+evaluatethis
+
+(defparameter *f1* (make-instance 'summer))
+
+#|
+observe:
+0> the sum of the values of the kids is 0
+0> the values of the kids are nil
+
+;----------------------------------------------------------|#
+
+#+evaluatethis
+
+(push (make-instance 'model
+ :fm-parent *f1*
+ :value 1) (kids *f1*))
+
+#| observe:
+0> the values of the kids are (1)
+0> the sum of the values of the kids is 1
+
+;----------------------------------------------------------|#
+
+#+evaluatethis
+
+(push (make-instance 'model
+ :fm-parent *f1*
+ :value 2) (kids *f1*))
+
+#| observe:
+0> the values of the kids are (2 1)
+0> the sum of the values of the kids is 3
+
+;----------------------------------------------------------|#
+
+#+evaluatethis
+
+(setf (kids *f1*) nil)
+
+#| observe:
+0> the values of the kids are nil
+0> the sum of the values of the kids is 0
+
+now before closing, it occurs to me you'll need a little
+introduction to the semantics of ^slot-x macros generated
+by the defmodel macro. here is another way to define our stone:
+
+|#
+
+#+evaluatethis
+
+(setq *s2* (make-instance 'stone
+ :accel 2
+ :time-elapsed (c-in 3)
+ :distance (c? (+ (^accel) (^time-elapsed)))))
+
+#| in the olden days of cells, when they were called
+semaphors, the only way to establish a dependency
+was to use some form like:
+
+ (^some-slot some-thing)
+
+that is no longer necessary. now any dynamic access:
+
+(1) during evaluation of a form wrapped in (c?...)
+(2) to a cell, direct or inside some function
+(3) using accessors named in the defmodel form (not slot-value)
+
+...establishes a dependency. so why still have the ^slot macros?
+
+one neat thing about the ^slot macros is that the default
+argument is self, an anaphor set up by c? and its ilk, so
+one can make many rules a little easier to follow by simply
+coding (^slot). another is convenient specification of
+synapses on dependencies, a more advanced topic we can
+ignore a while.
+
+
+|#
Added: dependencies/trunk/cells/doc/cell-doc.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/doc/cell-doc.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,181 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+#|
+
+Deep thoughts: Where a program implements a model using interesting, long-lived state (such
+as the position of other players on a virtual soccer field in a game program), some state will
+be computed off of other such state. Not everything is raw input. eg, a player might
+have set himself a task such as "tackle opponent" based on a higher-level computation
+of what is going on in the game, and then "current task" is both computed yet long-lived.
+
+Spread throughout the application will be code here and code there
+which makes an interesting computation using other program state ("given what I can see,
+which player if any has the ball") and decides
+to do something, which may be (a) to act outside the program such as cause some component
+to be redrawn (say, to manifest its new color, in this case if a debugging hack uses
+the game display to show which player the algorithm has settled on) or (b) to cache the
+observation as a guide to other algorithms. My current task "tackle opponent" controls
+inter alia the player's choices on which way to turn and how fast to run in order
+to close on the opponent.
+
+Whenever a program receives an input, such as the mouse position or a keystroke or
+a message over a socket connection, some computations need to be repeated. In a
+multi-player game an external server will be deciding the position of the ball, and
+when that changes my program must rethink a lot of things which were decided based
+on the old position of the ball.
+
+Cells's job is to make sure that last bit goes smoothly, which we will define now.
+
+Suppose the system has reached the stable, valid state reached after
+autoinitialization of the initial model population...we'll worry about initialization
+ later. I like to think of a change to a variable such as the window's width as
+a /data pulse/, or /pulse/ for short. If we enumerate these pulses sequentially,
+we can state the Prime Directive of Cells as:
+
+ take a system gets from pulse n to n+1 smoothly.
+
+To handle concurrency, we can instead stamp pulses with the time. Then we can speak
+of time T and T+1, which will be time stamps such that no pulse known to the system
+has a time stamp between T and T+1. (Where we have concurrency and network latency,
+some regulating scheme will have to be found to make sure everyone has had a chance
+to "share" before T+1 is decided, given T and a new set of pulses. Let's duck that
+for now and assume a single thread in which each pulse also moves T to T+1.) Now
+we can restate the Cells manifesto:
+
+ take a system from time T to time T+1 smoothly
+
+Your next question should be, what does "smoothly" mean? First, some formal definitions.
+
+Let's call the slot changed by the triggering pulse X, as in "X marks the spot" where
+the system perturbation began. X might be the mouse position as fed to the application
+by the operating system.
+
+Now let's talk of Cells being "at" some time Tn or other. Time starts at T0. The application
+makes its first model instances and brings that cluster to life, sweeping the cluster
+evaluating ruled cells. Eventually they have all been computed, and we are at T1. After this
+everything is Tn or Tn+1.
+
+-- When a pulse Pn+1 occurs, it takes the system from Tn to Tn+1.
+
+Now suppose P is a change to slot X, the mouse position of some "system" instance we
+are using to model the application environment.
+
+-- We say slot X is now "at" time Tn+1, because it trivially reflects the value of Pn+1
+
+If another cell happens to have used X in its most recent calculation, it needs to be
+recalculated. Once it is recalculated, we say it too has reached Tn+1. And if any Cell
+did not involve in its calculation X, directly or indirectly through some other cell,
+then we also think of it as being at time T+1. It is current with pulse Pn+1 because
+Pn+1 changes nothing of relevance to it.
+
+With those definitions in mind, here are the qualities of a smooth
+transition from T to T+1:
+
+(1) Completeness: everyone gets to Tn+1: every internal calculation affected directly or
+indirectly by X will be recalculated.
+
+(1a) Completeness: any and only those Cs which actually change in value getting from Cn to Cn+1
+will have that change echoed.
+
+(2) Efficiency: only those calculations will execute. There is no reason to run a rule
+if nothing affecting its outcome has changed.
+
+(2a) Efficiency: a calculation is affected by a transition of some cell to Tn+1
+iff Cn+1 is different from Cn. ie, if X actually changes and some cell A which uses
+it dutifully recalculates but comes up with the same result (it might involve a min or
+max function), then some other cell B which uses A does not need to be recalculated.
+
+(3) Simplicity: calculations will run only once (no re-entrance). More efficient as well.
+This may seem obvious, but certain engineering attempts have resulted in reentrance.
+But then one has to worry about backtracking. The idea is to make
+programming easier, so we won't ask developers to worry about re-entrance. Not
+that we are encouraging side-effects in Cell rules. Anyway....
+
+(4) Consistency: no rule when it runs will access any cell not already at T+1.
+
+(5) Consistency II: akin to the first, no echo of n+1 will employ any data not at Tn+1.
+
+(6) Completeness II: Tn+2 does not happen until the transition to Tn+1 satisfies
+the above requirements.
+
+If we timestamp every Cell as it moves from Cn to Cn+1, it all just works if we
+move Tn to Tn+1 and follow the above requirements.
+
+First, Tn+1 was reached by X itself receiving pulse N+1 and becoming Xn+1.
+
+Rule 2 requires us to determine if pulse N+1 actually change X. In the case of
+a window being resized only vertically, the reshape event will include a "new"
+value for width which is the same as the old.
+
+If X turns out not to have changed, we do not move time to Tn+1. Efficiencies 2 and 2a.
+
+But if X has changed, we now have Tn+1 and X reaches Xn+1 trivially.
+
+Now rule 1 requires us to recalculate all of X's users, and if one of
+those changes, likewise notify their users. Eventually everyone gets notified, so
+we look good on Rule 1.
+
+But now we have a problem. What if A and B are users of X, but A also uses C which uses B?
+A's rule, when it runs, needs to see Cn+1 to satisfy rule 4. We cannot just run the rule
+for C because we do not know until B gets calculated whether /it/ will change. We know
+X has changed, but maybe B will come up with the same answer as before. In which case,
+by the definitions above, C is already Cn+1 and recalculating it would be a waste.
+
+The solution is a little tricky: descend the "used" links from C looking for X. When
+we come to a terminus (a c-variable which is not X), we flag that as being at n+1 and
+return nil. If at any ruled node all useds return nil, we flag the ruled cell as
+being at n+1 and return nil.
+
+But where we get to X, we return T. Where a ruled node gets T back from any used Cell
+it kicks off its own calculation, returning T iff it changes. But before returning it
+echos. Should that echo involve some user-level read of some cell which is at Cn,
+accessor processing will include these safeguards which check to see if any used value
+is at Tn+1 and recalculate "just in time". This means we need a special variable which
+indicates when data pulse propagation is underway:
+
+ (let ((*propagating* (setf *time* (get-internal-real-time))))....
+
+That way if *propagating* is false there is no need to do anything but return valid
+values.
+
+Anyway, it looks as if echo requirements can be satisfied, and that completes the
+picture. But we have a problem. If some cell H (for high up in the dependency graph)
+uses both A and C, it is possible for X to tell A to recalculate, which will lead
+to A asking C to recalculate, which will do so and tell H to recalculate, which will
+ask A for its current value. Deadlock, and again this cannot be detected via lookahead
+because H's rule may not branch to A until just this pulse.
+
+The trick is that all we need from C when it gets accessed is its value. yes, we can tell
+now that H must be recalculated at some point, but A has not gone after H and will not
+so recalculating H can wait. If A /does/ go after H the above framework will see to
+it that H gets recalculated. But in this case H can wait (but not be forgotten).
+
+So we simply add H to a fifo queue of deferred dependencies to be revisited before
+Tn+1 can be considered attained.
+
+
+
+|#
+
Added: dependencies/trunk/cells/doc/cells-overview.pdf
==============================================================================
Binary files (empty file) and dependencies/trunk/cells/doc/cells-overview.pdf Tue Jan 26 15:20:07 2010 differ
Added: dependencies/trunk/cells/doc/hw.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/doc/hw.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,72 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defmodel computer ()
+ ((hear :cell :ephemeral :accessor hear :initform (c-in nil))
+ (salutation :initarg :salutation :accessor salutation :initform "hello")
+ (response :initform nil :initarg :response
+ :unchanged-if ‘string= :accessor response)))
+
+(def-c-output response ()
+ (when new-value
+ (format t "~&hear: ~a~%respond: ~a" (hear self) new-value)))
+
+(defun hello-world ()
+ (cell-reset)
+ (let ((system (make-instance 'computer
+ :response (c? (let ((r (case (hear self)
+ (:knock-knock "who's there?")
+ (:world (concatenate 'string
+ (salutation self)
+ ", "
+ (string (hear self))))
+ ((nil) "<silence>"))))
+ (if (string= r .cache)
+ (format nil "i said, \"~a\"" r)
+ r))))))
+ (format t "~&to-be initialization complete")
+ (setf (hear system) :knock-knock)
+ (setf (hear system) :knock-knock)
+ (setf (hear system) :world)
+ (setf (salutation system) "hiya")
+ (values)))
+
+#+(or)
+(hello-world)
+
+#| output
+
+hear: nil
+respond: <silence>
+hear: knock-knock
+respond: who's there?
+hear: knock-knock
+respond: i said, "who's there?"
+hear: world
+respond: hello, world
+
+|#
+
Added: dependencies/trunk/cells/doc/motor-control.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/doc/motor-control.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,157 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells -*-
+;;;
+;;; Copyright © 2004 by Bill Clementson
+;;;
+;;; Reprinted, reformatted, and modestly revised by permission.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+#|
+
+Experimenting with Cells
+----------------------------
+Thursday, September 11, 2003
+
+Kenny Tilton has been talking about his Cells implementation on comp.lang.lisp for some time
+but I've only just had a look at it over the past few evenings. It's actually pretty neat.
+Kenny describes Cells as, conceptually, analogous to a spreadsheet cell (e.g. -- something
+in which you can put a value or a formula and have it updated automatically based on changes
+in other "cell" values). Another way of saying this might be that Cells allows you to define
+classes whose slots can be dynamically (and automatically) updated and for which standard
+observers can be defined that react to changes in those slots.
+
+Hmmm, maybe an example works best. Here's one that's a variation on one of the examples
+included in the latest distribution. I'll create a "motor" object that reacts to changes
+in the motor's operating temperature. If the temperature exceeds 100 degrees, the motor will
+need to be shut off. If it is shut off, the flow from the fuel pump will also need to be
+closed (otherwise, we get a big pool of fuel on the floor).
+
+So, by using Cells in this example, the following will be demonstrated:
+
+ * Create slots whose values vary based on a formula. The formula can be defined at
+ either class definition time or at object instantiation time.
+
+ * Dynamically (and automatically) update dependent slot variables (maintaining consistency
+ between dependent class attributes).
+
+ * Create Observers that react to changes in slot values to handle "external"
+ actions (e.g. - GUI updates, external API calls, etc.).
+
+ * Automatically filter slot changes so that we only update dependent slots
+ when the right granularity of change occurs.
+
+First, define the motor class (Note: defmodel is a macro that wraps a class
+definition and several method definitions):
+|#
+
+(in-package :cells)
+
+(defmodel motor ()
+ ((status :initarg :status :accessor status :initform nil)
+ (fuel-pump :initarg :fuel-pump :accessor fuel-pump
+ :initform (c? (ecase (^status) (:on :open) (:off :closed))))
+ (temp :initarg :temp :accessor temp :initform (c-in 0))))
+
+#+test
+(progn
+ (cells-reset)
+ (setf (status (make-instance 'motor :status :on)) 42))
+
+#|
+
+Note that "status" is a cell with no initial value or formula, "fuel-pump" is
+a cell that has a formula that depends on the value of "status" (the ^status notation
+is shorthand to refer to a slot in the same instance), and "temp" is initialized to zero.
+
+Next, define observers (this is an optional step) using a Cells macro.
+These observers act on a change in a slot's value. They don't actually update
+any dependent slots (this is done automatically by Cells and the programmer
+doesn't have to explicitly call the slot updates), they just provide a mechanism
+for the programmer to handle outside dependencies. In this example, we're just
+printing a message; however, in a real program, we would be calling out to something
+like an Allen Bradley controller to turn the motor and fuel pump on/off.
+
+|#
+
+(defobserver status ((self motor))
+ (trc "motor status changing from" old-value :to new-value))
+
+(defobserver fuel-pump ((self motor))
+ (trc "motor fuel-pump changing from" old-value :to new-value))
+
+(defobserver temp ((self motor))
+ (trc "motor temperature changing from" old-value :to new-value))
+
+#|
+
+Then, create an instance of the motor. Note that we programmatically assign
+a formula to the "status" slot. The formula states that when the temperature
+rises above 100 degrees, we change the status to "off". Since the temperature may
+fluctuate around 100 degrees a bit before it moves decisively one way or
+the other (and we don't want the motor to start turning off and on as we get
+minor temperature fluctuations around the 100 degree mark), we use another
+Cells feature ("Synapses" allow for pre-defined filters to be applied to a
+slot's value before it is used to update other slots) to filter the temperatures
+for small variations. Note that the formula is being assigned to the "status"
+slot at instantiation time as this gives us the ability to create different
+formulas for different types of motors without subclassing "motor".
+
+|#
+
+#+evaluatethis
+
+(defparameter *motor1*
+ (make-instance 'motor
+ :status (c? (if (< (f-sensitivity :tmp (0.05) (^temp)) 100)
+ :on :off))))
+
+#|
+
+This alone produces the following results as the Cells engine gets the motor
+instance fully active, which requires getting the real-world motor
+in synch with the CLOS instance:
+
+0> motor status changing from | NIL | :TO :ON
+0> motor fuel-pump changing from | NIL | :TO :OPEN
+0> motor temperature changing from | NIL | :TO 0
+
+Then we test the operation of the motor by changing the motor's
+temperature (starting at 99 degrees and increasing it by 1 degree +/- a small random variation).
+
+|#
+
+#+evaluatethis
+
+(dotimes (x 2)
+ (dotimes (y 10)
+ (let ((newtemp (+ 99 x (random 0.07) -.02)))
+ (setf (temp *motor1*) newtemp))))
+
+#|
+
+This produces the following results, which will vary from run to run because of
+the use of a random amount to simulate real-world variability:
+
+0> motor temperature changing from NIL :TO 0
+0> motor temperature changing from 0 :TO 98.99401
+0> motor temperature changing from 98.99401 :TO 99.01954
+[snipped 8 intermediate readings]
+0> motor temperature changing from 99.00016 :TO 100.00181
+0> motor status changing from :ON :TO :OFF
+0> motor fuel-pump changing from :OPEN :TO :CLOSED
+0> motor temperature changing from 100.00181 :TO 100.0177
+0> motor temperature changing from 100.0177 :TO 99.98742
+0> motor temperature changing from 99.98742 :TO 99.99313
+[snipped 6 intermediate readings]
+
+Notice how the fsensitivity synapse prevents minor fluctuations around 100 degrees
+from causing the motor to start turning itself on and off in rapid succession,
+possibly causing it to flood or fail in some way.
+
+|#
\ No newline at end of file
Added: dependencies/trunk/cells/family-values.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/family-values.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,96 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(family-values family-values-sorted
+ sort-index sort-direction sort-predicate sort-key
+ ^sort-index ^sort-direction ^sort-predicate ^sort-key)))
+
+(defmodel family-values (family)
+ (
+ (kv-collector :initarg :kv-collector
+ :initform #'identity
+ :reader kv-collector)
+
+ (kid-values :initform (c? (when (kv-collector self)
+ (funcall (kv-collector self) (^value))))
+ :accessor kid-values
+ :initarg :kid-values)
+
+ (kv-key :initform #'identity
+ :initarg :kv-key
+ :reader kv-key)
+
+ (kv-key-test :initform #'equal
+ :initarg :kv-key-test
+ :reader kv-key-test)
+
+ (kid-factory :initform #'identity
+ :initarg :kid-factory
+ :reader kid-factory)
+
+ (.kids :initform (c? (c-assert (listp (kid-values self)))
+ (let ((new-kids (mapcan (lambda (kid-value)
+ (list (or (find kid-value .cache
+ :key (kv-key self)
+ :test (kv-key-test self))
+ (trc nil "family-values forced to make new kid"
+ self .cache kid-value)
+ (funcall (kid-factory self) self kid-value))))
+ (^kid-values))))
+ (nconc (mapcan (lambda (old-kid)
+ (unless (find old-kid new-kids)
+ (when (fv-kid-keep self old-kid)
+ (list old-kid))))
+ .cache)
+ new-kids)))
+ :accessor kids
+ :initarg :kids)))
+
+(defmethod fv-kid-keep (family old-kid)
+ (declare (ignorable family old-kid))
+ nil)
+
+(defmodel family-values-sorted (family-values)
+ ((sorted-kids :initarg :sorted-kids :accessor sorted-kids
+ :initform nil)
+ (sort-map :initform (c-in nil) :initarg :sort-map :accessor sort-map)
+ (.kids :initform (c? (c-assert (listp (kid-values self)))
+ (mapsort (^sort-map)
+ (the-kids
+ (mapcar (lambda (kid-value)
+ (trc "making kid" kid-value)
+ (or (find kid-value .cache :key (kv-key self) :test (kv-key-test self))
+ (trc nil "family-values forced to make new kid" self .cache kid-value)
+ (funcall (kid-factory self) self kid-value)))
+ (^kid-values)))))
+ :accessor kids
+ :initarg :kids)))
+
+(defun mapsort (map data)
+ ;;(trc "mapsort map" map)
+ (if map
+ (stable-sort data #'< :key (lambda (datum) (or (position datum map)
+ ;(trc "mapsort datum not in map" datum)
+ (1+ (length data)))))
+ data))
+
+(defobserver sorted-kids ()
+ (setf (sort-map self) new-value)) ;; cellular trick to avoid cyclicity
\ No newline at end of file
Added: dependencies/trunk/cells/family.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/family.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,264 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+ (export '(model value family dbg .pa
+ kids kid1 ^k1 kid2 ^k2 last-kid ^k-last perishable)))
+
+(defmodel model ()
+ ((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name)
+ (.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent)
+ (.dbg-par :cell nil :initform nil)
+ (.value :initform nil :accessor value :initarg :value)
+ (register? :cell nil :initform nil :initarg :register? :reader register?)
+ (zdbg :initform nil :accessor dbg :initarg :dbg)))
+
+(defmethod not-to-be :around ((self model))
+ (setf (slot-value self '.dbg-par) (fm-parent self)) ;; before it gets zapped
+ (call-next-method))
+
+(defmethod initialize-instance :after ((self model) &key)
+ (when (register? self)
+ (fm-register self)))
+
+(defmethod print-cell-object ((md model))
+ (or (md-name md) :md?))
+
+(defmethod fm-parent (other)
+ (declare (ignore other))
+ nil)
+
+(defmethod (setf fm-parent) (new-value other)
+ (declare (ignore other))
+ new-value)
+
+(defmethod print-object ((self model) s)
+ #+shhh (format s "~a" (type-of self))
+ (format s "~a~a" (if (mdead self) "DEAD!" "")
+ (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))
+ other)
+
+(defmethod md-name ((nada null))
+ (unless (c-stopped)
+ (c-stop :md-name-on-null)
+ (break "md-name called on nil")))
+
+(defmethod md-name ((sym symbol)) sym)
+
+(defmethod shared-initialize :around ((self model) slotnames &rest initargs &key fm-parent)
+ (declare (ignorable initargs slotnames fm-parent))
+
+ (call-next-method)
+
+ (when (slot-boundp self '.md-name)
+ (unless (md-name self)
+ (setf (md-name self) (gentemp (string (c-class-name (class-of self)))))))
+
+ (when (and (slot-boundp self '.fm-parent)
+ (fm-parent self)
+ (zerop (adopt-ct self)))
+ (md-be-adopted self)))
+
+(defmodel perishable ()
+ ((expiration :initform nil :accessor expiration :initarg :expiration)))
+
+(defobserver expiration ()
+ (when new-value
+ (not-to-be self)))
+
+(defvar *parent* nil)
+
+(defmodel family (model)
+ ((.kid-slots :cell nil
+ :initform nil
+ :accessor kid-slots
+ :initarg :kid-slots)
+ (.kids :initform (c-in nil) ;; most useful
+ :owning t
+ :accessor 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)))
+ (mop::finalize-inheritance c)
+ (class-precedence-list c))
+
+(defmacro the-kids (&rest kids)
+ `(let ((*parent* self))
+ (packed-flat! , at kids)))
+
+(defmacro s-sib-no () `(position self (kids .parent)))
+
+(defmacro gpar ()
+ `(fm-grandparent self))
+
+(defmacro nearest (self-form type)
+ (let ((self (gensym)))
+ `(bwhen (,self ,self-form)
+ (if (typep ,self ',type) ,self (upper ,self ,type)))))
+
+(defun kid1 (self) (car (kids self)))
+
+(export! first-born-p)
+(defun first-born-p (self)
+ (eq self (kid1 .parent)))
+
+(defun kid2 (self) (cadr (kids self)))
+(defmacro ^k1 () `(kid1 self))
+(defmacro ^k2 () `(kid2 self))
+
+(defun last-kid (self) (last1 (kids self)))
+(defmacro ^k-last () `(last-kid self))
+
+;; /// redundancy in following
+
+(defmacro psib (&optional (self-form 'self))
+ (let ((self (gensym)))
+ `(bwhen (,self ,self-form)
+ (find-prior ,self (kids (fm-parent ,self))))))
+
+(defmacro nsib (&optional (self-form 'self))
+ (let ((self (gensym)))
+ `(bwhen (,self ,self-form)
+ (cadr (member ,self (kids (fm-parent ,self)))))))
+
+(defun prior-sib (self)
+ (let ((kid (gensym)))
+ `(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)))
+ (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))
+ (c-break "2nd adopt ~a, by ~a" self fm-parent))
+
+ (incf (adopt-ct self))
+ (trc nil "getting adopted" self :by fm-parent)
+ (bwhen (kid-slots-fn (kid-slots (fm-parent self)))
+ (dolist (ks-def (funcall kid-slots-fn self) self)
+ (let ((slot-name (ks-name ks-def)))
+ (trc nil "got ksdef " slot-name (ks-if-missing ks-def))
+ (when (md-slot-cell-type selftype slot-name)
+ (trc nil "got cell type " slot-name )
+ (when (or (not (ks-if-missing ks-def))
+ (and (null (c-slot-value self slot-name))
+ (null (md-slot-cell self slot-name))))
+ (trc nil "ks missing ok " slot-name)
+ (multiple-value-bind (c-or-value suppressp)
+ (funcall (ks-rule ks-def) self)
+ (unless suppressp
+ (trc nil "md-install-cell " slot-name c-or-value)
+ (md-install-cell self slot-name c-or-value)))))))))
+
+(defobserver .kids ((self family) new-kids old-kids)
+ (c-assert (listp new-kids) () "New kids value for ~a not listp: ~a ~a" self (type-of new-kids) new-kids)
+ (c-assert (listp old-kids))
+ (c-assert (not (member nil old-kids)))
+ (c-assert (not (member nil new-kids)))
+ (bwhen (sample (find-if-not 'fm-parent new-kids))
+ (c-break "New as of Cells3: parent must be supplied to make-instance of ~a kid ~a"
+ (type-of sample) sample))
+ (trc nil ".kids output > entry" new-kids (mapcar 'fm-parent new-kids)))
+
+(defmethod kids ((other model-object)) nil)
+
+
+
+;------------------ kid slotting ----------------------------
+;
+(defstruct (kid-slotdef
+ (:conc-name nil))
+ ks-name
+ ks-rule
+ (ks-if-missing t))
+
+(defmacro mk-kid-slot ((ks-name &key if-missing) ks-rule)
+ `(make-kid-slotdef
+ :ks-name ',ks-name
+ :ks-rule (lambda (self)
+ (declare (ignorable self))
+ ,ks-rule)
+ :ks-if-missing ,if-missing))
+
+(defmacro def-kid-slots (&rest slot-defs)
+ `(lambda (self)
+ (declare (ignorable self))
+ (list , at 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
Added: dependencies/trunk/cells/fm-utilities.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/fm-utilities.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,735 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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.
+
+$Header: /project/cells/cvsroot/cells/fm-utilities.lisp,v 1.22 2008-10-12 01:21:07 ktilton Exp $
+|#
+
+
+(in-package :cells)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export
+ '(;; Family member creation
+ make-part
+ mk-part
+ mk-part-spec
+ upper
+ u^
+ container
+ container-typed
+
+ ;; Family member finding
+ fm-descendant-typed
+ fm-ascendant-typed
+ fm-kid-named
+ fm-descendant-named
+ fm-ascendant-named
+ fm-ascendant-some
+ fm-ascendant-if
+ fm-descendant-if
+ fm-descendant-common
+ fm-collect-if
+ fm-collect-some
+ fm-value-dictionary
+ fm-max
+ fm-traverse
+ fm-traverse-bf
+ fm-ordered-p
+ sub-nodes
+ fm-ps-parent
+ with-like-fm-parts
+ do-like-fm-parts
+ true-that
+ fm-do-up
+ fm-gather
+ fm-find-all
+ fm-find-next
+ fm-find-next-within
+ fm-find-prior
+ fm-find-prior-within
+ fm-find-last-if
+ fm-prior-sib
+ fm-next-sib-if
+ fm-next-sib
+ ^fm-next-sib
+ fm-find-if
+
+ ;; Family ordering
+ fm-kid-add
+ fm-kid-insert-last
+ fm-kid-insert-first
+ fm-kid-insert
+ fm-kid-remove
+ fm-quiesce-all
+ fm-kid-replace
+
+ ;; Family high-order ops
+ fm-min-kid
+ fm-max-kid
+ fm-other
+ fmv
+ fm-otherx
+ fm-other-v
+ fm-otherv?
+ fm-other?
+ fm-other!
+ fm^
+ fm?
+ fm!
+ fm!v
+ fm-other?!
+ fm-collect
+ fm-map
+ fm-mapc
+ fm-pos
+ fm-count-named
+ fm-top
+ fm-first-above
+ fm-nearest-if
+ fm-includes
+ fm-ancestor-p
+ fm-kid-containing
+ fm-ascendant-p
+ fm-find-one
+ fm-find-kid
+ fm-kid-typed
+
+ ;; Other family stuff
+ make-name
+ name-root
+ name-subscript
+ kid-no
+
+ ;; Debug flags
+ *fmdbg*
+
+ )))
+
+(defparameter *fmdbg* nil)
+
+(defun make-part (partname part-class &rest initargs)
+ ;;(trc "make-part > name class" partname partclass)
+ (when part-class ;;a little programmer friendliness
+ (apply #'make-instance part-class (append initargs (list :md-name partname)))))
+
+(defmacro mk-part (md-name (md-class) &rest initargs)
+ `(make-part ',md-name ',md-class , at initargs
+ :fm-parent (progn (assert self) self)))
+
+(defmethod make-part-spec ((part-class symbol))
+ (make-part part-class part-class))
+
+(defmethod make-part-spec ((part model))
+ part)
+
+
+(defmacro upper (self &optional (type t))
+ `(container-typed ,self ',type))
+
+(defmacro u^ (type)
+ `(upper self ,type))
+
+(defmethod container (self) (fm-parent self))
+
+;;;(defmethod container-typed ((self model-object) type)
+;;; (let ((parent (container self))) ;; fm- or ps-parent
+;;; (cond
+;;; ((null parent) nil)
+;;; ((typep parent type) parent)
+;;; (t (container-typed parent type)))))
+
+(defmethod container-typed ((self model-object) type)
+ (let ((parent (fm-parent self))) ;; fm- or ps-parent
+ (cond
+ ((null parent) nil)
+ ((typep parent type) parent)
+ (t (container-typed parent type)))))
+
+(defun fm-descendant-typed (self type)
+ (when self
+ (or (find-if (lambda (k) (typep k type)) (kids self))
+ (some (lambda (k)
+ (fm-descendant-typed k type)) (kids self)))))
+
+(defun fm-kid-named (self name)
+ (find name (^kids) :key 'md-name))
+
+(defun fm-descendant-named (parent name &key (must-find t))
+ (fm-find-one parent name :must-find must-find :global-search nil))
+
+(defun fm-ascendant-named (parent name)
+ (when parent
+ (or (when (eql (md-name parent) name)
+ parent)
+ (fm-ascendant-named (fm-parent parent) name))))
+
+(defun fm-ascendant-typed (parent name)
+ (when parent
+ (or (when (typep parent name)
+ parent)
+ (fm-ascendant-typed (fm-parent parent) name))))
+
+(defun fm-ascendant-some (parent some-function)
+ (when (and parent some-function)
+ (or (funcall some-function parent)
+ (fm-ascendant-some (fm-parent parent) some-function))))
+
+(defun fm-ascendant-if (self test)
+ (when (and self test)
+ (or (when (funcall test self)
+ self)
+ (fm-ascendant-if .parent test))))
+
+(defun fm-descendant-if (self test)
+ (when (and self test)
+ (or (when (funcall test self)
+ self)
+ (loop for k in (^kids)
+ thereis (fm-descendant-if k test)))))
+
+(defun fm-ascendant-common (d1 d2)
+ (fm-ascendant-some d1 (lambda (node)
+ (when (fm-includes node d2)
+ node))))
+
+(defun fm-collect-if (tree test &optional skip-top dependently)
+ (let (collection)
+ (fm-traverse tree (lambda (node)
+ (unless (and skip-top (eq node tree))
+ (when (funcall test node)
+ (push node collection))))
+ :with-dependency dependently)
+ (nreverse collection)))
+
+(defun fm-collect-some (tree test &optional skip-top dependently)
+ (let (collection)
+ (fm-traverse tree (lambda (node)
+ (unless (and skip-top (eq node tree))
+ (bwhen (s (funcall test node))
+ (push s collection))))
+ :with-dependency dependently)
+ (nreverse collection)))
+
+(defun fm-value-dictionary (tree value-fn &optional include-top)
+ (let (collection)
+ (fm-traverse tree
+ (lambda (node)
+ (when (or include-top (not (eq node tree)))
+ (bwhen (v (funcall value-fn node))
+ (push (cons (md-name node) v) collection)))))
+ (nreverse collection)))
+
+(defun fm-max (tree key)
+ (let (max)
+ (fm-traverse tree (lambda (node)
+ (if max
+ (setf max (max max (funcall key node)))
+ (setf max (funcall key node)))))
+ max))
+
+
+(defun fm-traverse (family applied-fn &key skip-node skip-tree global-search opaque with-dependency)
+ ;;(when *fmdbg* (trc "fm-traverse" family skipTree skipNode global-search))
+
+ (when family
+ (labels ((tv-family (fm)
+ (etypecase fm
+ (cons (loop for md in fm do (tv-family md)))
+ (model-object
+ (unless (eql fm skip-tree)
+ (let ((outcome (and (not (eql skip-node fm)) ;; skipnode new 990310 kt
+ (funcall applied-fn fm))))
+ (unless (and outcome opaque)
+ (dolist (kid (kids fm))
+ (tv-family kid))
+ ;(tv-family (mdValue fm))
+ )))))))
+ (flet ((tv ()
+ (tv-family family)
+ (when global-search
+ (fm-traverse (fm-parent family) applied-fn
+ :global-search t
+ :skip-tree family
+ :skip-node skip-node
+ :with-dependency t)))) ;; t actually just defaults to outermost call
+ (if with-dependency
+ (tv)
+ (without-c-dependency (tv))))))
+ (values))
+
+(defun fm-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)
+ (cond
+ ((eq n n1)(return-from fm-ordered-p t))
+ ((eq n n2)(return-from fm-ordered-p nil))))))
+
+
+(defmethod sub-nodes (other)
+ (declare (ignore other)))
+
+(defmethod sub-nodes ((self family))
+ (kids self))
+
+(defmethod fm-ps-parent ((self model-object))
+ (fm-parent self))
+
+(defmacro with-like-fm-parts ((parts-var (self like-class)) &body body)
+ `(let (,parts-var)
+ (fm-traverse ,self (lambda (node)
+ ;;(trc "with like sees node" node (type-of node) ',likeclass)
+ (when (typep node ',like-class)
+ (push node ,parts-var)))
+ :skip-node ,self
+ :opaque t)
+ (setf ,parts-var (nreverse ,parts-var))
+ (progn , at body)))
+
+(defmacro do-like-fm-parts ((part-var (self like-class) &optional return-var) &body body)
+ `(progn
+ (fm-traverse ,self (lambda (,part-var)
+ (when (typep ,part-var ',like-class)
+ , at body))
+ :skip-node ,self
+ :opaque t)
+ ,return-var)
+ )
+
+;;
+;; family member finding
+;;
+
+
+#|
+ (defun fm-member-named (kidname kids)
+ (member kidname kids :key #'md-name))
+ |#
+
+(defun true-that (that) (declare (ignore that)) t)
+;;
+;; eventually fm-find-all needs a better name (as does fm-collect) and they
+;; should be modified to go through 'gather', which should be the real fm-find-all
+;;
+
+(defun fm-do-up (self &optional (fn 'identity))
+ (when self
+ (funcall fn self)
+ (if .parent (fm-do-up .parent fn) self))
+ (values))
+
+(defun fm-gather (family &key (test #'true-that))
+ (packed-flat!
+ (cons (when (funcall test family) family)
+ (mapcar (lambda (fm)
+ (fm-gather fm :test test))
+ (kids family)))))
+
+(defun fm-find-all (family md-name &key (must-find t) (global-search t))
+ (let ((matches (catch 'fm-find-all
+ (with-dynamic-fn
+ (traveller (family)
+ (with-dynamic-fn
+ (filter (kid) (eql md-name (md-name kid)))
+ (let ((matches (remove-if-not filter (kids family))))
+ (when matches
+ (throw 'fm-find-all matches)))))
+ (fm-traverse family traveller :global-search global-search)))))
+ (when (and must-find (null matches))
+ (setf *stop* t)
+ (fm-traverse family (lambda (node)
+ (trc "known node" (md-name node))) :global-search global-search)
+ (break "fm-find-all > *stop*ping...did not find ~a ~a ~a" family md-name global-search)
+ ;; (error 'fm-not-found (list md-name family global-search))
+ )
+ matches))
+
+(defun fm-find-next (fm test-fn)
+ (fm-find-next-within fm test-fn))
+
+(defun fm-find-next-within (fm test-fn &optional upperbound &aux (fm-parent (unless (eql upperbound fm)
+ (fm-parent fm))))
+ (let ((sibs (and fm-parent (rest (member fm (kids fm-parent))))))
+ (or (dolist (s sibs)
+ (let ((winner (fm-find-if s test-fn)))
+ (when winner (return winner))))
+ (if fm-parent
+ (fm-find-next-within fm-parent test-fn upperbound)
+ (fm-find-if fm test-fn)))))
+
+(defun fm-find-prior (fm test-fn)
+ (fm-find-prior-within fm test-fn))
+
+(defun fm-find-prior-within (fm test-fn &optional upperbound &aux (fm-parent (unless (eql upperbound fm)
+ (fm-parent fm))))
+ (let ((sibs (and fm-parent (kids fm-parent))))
+ (or (loop with next-ok
+ for s on sibs
+ for last-ok = nil then (or next-ok last-ok)
+ when (eql fm (first s)) do (loop-finish)
+ finally (return last-ok)
+ do (setf next-ok (fm-find-last-if (car s) test-fn)))
+ (if fm-parent
+ (fm-find-prior-within fm-parent test-fn upperbound)
+ (fm-find-last-if fm test-fn)))))
+
+ (defun fm-find-last-if (family test-fn)
+ (let ((last))
+ (or (and (kids family)
+ (dolist (k (kids family) last)
+ (setf last (or (fm-find-last-if k test-fn) last))))
+ (when (funcall test-fn family)
+ family))))
+
+(defun fm-prior-sib (self &optional (test-fn #'true-that))
+ "Find nearest preceding sibling passing TEST-FN"
+ (chk self 'psib)
+ (let ((kids (kids (fm-parent self))))
+ (find-if test-fn kids :end (position self kids) :from-end t)))
+
+(defun fm-next-sib-if (self test-fn)
+ (some test-fn (cdr (member self (kids (fm-parent self))))))
+
+(defun fm-next-sib (self)
+ (car (cdr (member self (kids (fm-parent self))))))
+
+(defmacro ^fm-next-sib (&optional (self 'self))
+ (let ((s (gensym)))
+ `(let ((,s ,self))
+ (car (cdr (member ,s (kids (fm-parent ,s))))))))
+
+(defun find-prior (self sibs &key (test #'true-that))
+ (c-assert (member self sibs) () "find-prior of ~a does not find it in sibs arg ~a" self sibs)
+ (unless (eql self (car sibs))
+ (labels
+ ((fpsib (rsibs &aux (psib (car rsibs)))
+ (c-assert rsibs () "find-prior > fpsib > self ~s not found to prior off" self)
+ (if (eql self (cadr rsibs))
+ (when (funcall test psib) psib)
+ (or (fpsib (cdr rsibs))
+ (when (funcall test psib) psib)))))
+ (fpsib sibs))))
+
+(defun fm-find-if (family test-fn &key skip-top-p) ;; 99-03 kt why is thsi depth-first?
+ (c-assert test-fn)
+ (when family
+ (or (dolist (b (sub-nodes family))
+ (let ((match (fm-find-if b test-fn)))
+ (when match (return match))))
+ (when (and (not skip-top-p)
+ (funcall test-fn family))
+ family))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; family ordering
+;;;;
+(defun fm-kid-add (fm-parent kid &optional before)
+ (c-assert (or (null (fm-parent kid)) (eql fm-parent (fm-parent kid))))
+ (c-assert (typep fm-parent 'family))
+ (setf (fm-parent kid) fm-parent)
+ (fm-kid-insert kid before))
+
+(defun fm-kid-insert-last (goal &aux (fm-parent (fm-parent goal)))
+ (setf (kids fm-parent) (nconc (kids fm-parent) (list goal))))
+
+(defun fm-kid-insert-first (goal &aux (fm-parent (fm-parent goal)))
+ (setf (kids fm-parent) (cons goal (kids fm-parent))))
+
+(defun fm-kid-insert (kid &optional before &aux (da-kids (kids (fm-parent kid))))
+ (c-assert (or (null before) (eql (fm-parent kid) (fm-parent before))))
+ (setf (kids (fm-parent kid))
+ (if before
+ (if (eql before (car da-kids))
+ (cons kid da-kids)
+ (let ((cell (member before da-kids)))
+ (rplaca cell kid)
+ (rplacd cell (cons before (cdr cell)))
+ (cons (car da-kids) (rest da-kids))))
+ (if da-kids
+ (progn
+ (rplacd (last da-kids) (cons kid nil))
+ (cons (car da-kids) (rest da-kids)))
+ (cons kid da-kids)))))
+
+(defun fm-kid-remove (kid &key (quiesce t) &aux (parent (fm-parent kid)))
+ (when quiesce
+ (fm-quiesce-all kid))
+ (when parent
+ (setf (kids parent) (remove kid (kids parent)))
+ ;; (setf (fm-parent kid) nil) gratuitous housekeeping caused ensuing focus output
+ ;; image-invalidate to fail since no access to containing window via fm-parent chain
+ ))
+
+(defun fm-quiesce-all (md)
+ (md-quiesce md)
+ (dolist (kid (kids md))
+ (fm-quiesce-all kid)))
+
+(defun fm-kid-replace (old-kid new-kid &aux (fm-parent (fm-parent old-kid)))
+ (c-assert (member old-kid (kids fm-parent)) ()
+ "~&oldkid ~s not amongst kids of its fm-parent ~s"
+ old-kid fm-parent)
+ (when fm-parent ;; silly test given above assert--which is right?
+ (c-assert (typep fm-parent 'family))
+ (setf (fm-parent new-kid) fm-parent)
+ (setf (kids fm-parent) (substitute new-kid old-kid (kids fm-parent)))
+ ;;(rplaca (member oldkid (kids fm-parent)) newkid)
+ new-kid))
+
+;----------------------------------------------------------
+;;
+;; h i g h - o r d e r f a m i l y o p s
+;;
+;; currently not in use...someday?
+;;
+
+
+(defun fm-min-kid (self slot-name)
+ (or (loop for k in (^kids)
+ minimizing (funcall slot-name k))
+ 0))
+(defun fm-max-kid (self slot-name)
+ (or (loop for k in (^kids)
+ maximizing (funcall slot-name k))
+ 0))
+
+(defmacro fm-other (md-name &key (starting 'self) skip-tree (test '#'true-that))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find t
+ :skip-tree ,skip-tree
+ :global-search t
+ :test ,test))
+
+(defmacro fmv (name)
+ `(value (fm-other ,name)))
+
+(defmacro fm-otherx (md-name &key (starting 'self) skip-tree)
+ (if (eql starting 'self)
+ `(or (fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find t
+ :skip-tree ,skip-tree
+ :global-search t))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find t
+ :skip-tree ,skip-tree
+ :global-search t)))
+
+(defun fm-other-v (md-name starting &optional (global-search t))
+ (fm-find-one starting md-name
+ :must-find nil
+ :global-search global-search))
+
+(defmacro fm-otherv? (md-name &optional (starting 'self) (global-search t))
+ `(fm-other-v ,md-name ,starting ,global-search))
+
+(defmacro fm-other? (md-name &optional (starting 'self) (global-search t))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find nil
+ :global-search ,global-search))
+
+(defun fm-other! (starting md-name &optional (global-search t))
+ (fm-find-one starting md-name
+ :must-find t
+ :global-search global-search))
+
+(defmacro fm^ (md-name &key (skip-tree 'self) (must-find t))
+ `(without-c-dependency
+ (fm-find-one (fm-parent self) ,md-name
+ :skip-tree ,skip-tree
+ :must-find ,must-find
+ :global-search t)))
+
+
+(export! fm^v)
+(defmacro fm^v (id)
+ `(value (fm^ ,id)))
+
+(defmacro fm? (md-name &optional (starting 'self) (global-search t))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find nil
+ :global-search ,global-search))
+
+(defmacro fm! (md-name &optional (starting 'self))
+ `(without-c-dependency
+ (fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find t
+ :global-search nil)))
+
+(defmacro fm!v (id)
+ `(value (fm! ,id)))
+
+(defmacro fm-other?! (md-name &optional (starting 'self))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find nil
+ :global-search nil))
+
+(defmacro fm-collect (md-name &key (must-find t))
+ `(fm-find-all self ',md-name :must-find ,must-find)) ;deliberate capture
+
+(defmacro fm-map (fn md-name)
+ `(mapcar ,fn (fm-find-all self ',md-name))) ;deliberate capture
+
+(defmacro fm-mapc (fn md-name)
+ `(mapc ,fn (fm-find-all self ',md-name))) ;deliberate capture
+
+(defun fm-pos (goal &aux (fm-parent (fm-parent goal)))
+ (when fm-parent
+ (or (position goal (kids fm-parent))
+ (length (kids fm-parent))))) ;; ?!!
+
+(defmacro fm-count-named (family md-name &key (global-search t))
+ `(length (fm-find-all ,family ,md-name
+ :must-find nil
+ :global-search ,global-search)))
+;---------------------------------------------------------------
+(defun fm-top (fm &optional (test #'true-that) &aux (fm-parent (fm-parent fm)))
+ (cond ((null fm-parent) fm)
+ ((not (funcall test fm-parent)) fm)
+ (t (fm-top fm-parent test))))
+
+(defun fm-first-above (fm &key (test #'true-that) &aux (fm-parent (fm-parent fm)))
+ (cond ((null fm-parent) nil)
+ ((funcall test fm-parent) fm-parent)
+ (t (fm-first-above fm-parent :test test))))
+
+(defun fm-nearest-if (test fm)
+ (when fm
+ (if (funcall test fm)
+ fm
+ (fm-nearest-if test (fm-parent fm)))))
+
+(defun fm-includes (fm sought)
+ (fm-ancestor-p fm sought))
+
+(defun fm-ancestor-p (fm sought)
+ (c-assert fm)
+ (when sought
+ (or (eql fm sought)
+ (fm-includes fm (fm-parent sought)))))
+
+(defun fm-kid-containing (fm-parent descendant)
+ (with-dynamic-fn (finder (node) (not (eql fm-parent node)))
+ (fm-top descendant finder)))
+
+;;; above looks confused, let's try again
+
+(defun fm-ascendant-p (older younger)
+ (cond
+ ((null (fm-parent younger)) nil)
+ ((eq older (fm-parent younger)) t)
+ (t (fm-ascendant-p older (fm-parent younger)))))
+
+(defun make-name (root &optional subscript)
+ (if subscript (list root subscript) root))
+
+(defun name-root (md-name)
+ (if (atom md-name) md-name (car md-name)))
+
+(defun name-subscript (md-name)
+ (when (consp md-name) (cadr md-name)))
+
+(defun fm-find-one (family md-name &key (must-find t)
+ (global-search t) skip-tree (test #'true-that)
+ &aux diag)
+ (count-it :fm-find-one)
+ (flet ((matcher (fm)
+ (when diag
+ (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)))
+ (progn
+ (when diag
+ (trc "fm-find-one testing" fm))
+ (funcall test fm)))
+ (throw 'fm-find-one fm))))
+ #-lispworks (declare (dynamic-extent matcher))
+ (trc nil "fm-find-one> entry " md-name family)
+ (let ((match (catch 'fm-find-one
+ (fm-traverse family #'matcher
+ :skip-tree skip-tree
+ :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)
+ (setq diag t must-find nil)
+ (fm-traverse family #'matcher
+ :skip-tree skip-tree
+ :global-search global-search)
+ (c-break "fm-find-one > *stop*ping...did not find ~a ~a ~a" family md-name global-search)
+ )
+ match)))
+
+(defun fm-find-kid (self name)
+ (find name (kids self) :key #'md-name))
+
+(defun fm-kid-typed (self type)
+ (c-assert self)
+ (find type (kids self) :key #'type-of))
+
+(defun kid-no (self)
+ (unless (typep self 'model-object)
+ (break "not a model object ~a" self))
+ (when (and self (fm-parent self))
+ (c-assert (member self (kids (fm-parent self))))
+ (position self (kids (fm-parent self)))))
Added: dependencies/trunk/cells/gui-geometry/coordinate-xform.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/coordinate-xform.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,287 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
+#|
+
+Copyright (C) 2004 by Kenneth William 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 :gui-geometry)
+
+(defconstant *reference-dpi* 1440)
+
+(let (
+ (logical-dpi 96) ;;1440)
+ ; This is cello's internal dots per inch. This value is germane only if size references are unqualified by a function call.
+ ; Size references should always be qualified, as in (:pts 6), except when specifying pen widths.
+ ; (Pen widths may pose a special case -- we may need to match screen pens to print pens.)
+
+ (scan-resolution 300)
+ ; This is the desired scan resolution, and the assumed resolution of all scans.
+ ; Hypothetically, a scanner not capable of scanning at 300 dpi could make a big hash of this scheme.
+ ; Rather than even pretend to support multiple resolutions within a study, for now we'll enforce 300 across the board.
+ ; Dependencies on this spec can be identified by searching on scan-resolution.
+
+ (logical-screen-resolution 96)
+ ; This is the internal logical screen resolution, which does _not_ have to equal the current LOGPIXELSX (LOGPIXELSY) value
+ ; reported by GetDeviceCaps. The original thought was that we could use this to rescale _all_ drawing on the fly. Now that
+ ; idea is being superseded by targetRes, but this functions (1) as a tacit targetRes for the outer window and (2) as a magic
+ ; number to complicate debugging [we need to root out a few references in .bmp drawing, I think].
+
+ ;;(printer-resolution 600) ; /// improve #'cs-printer-resolution to bypass this.
+
+ ;;(emf-resolution 600)
+
+ )
+
+ (declare (ignorable logical-dpi scan-resolution logical-screen-resolution printer-resolution))
+
+ ; Notice the somewhat nonstandard naming convention:
+ ; #'uInches takes logical inches and returns logical units (DPI)
+ ; so, for instance, if logical-dpi = 1440, then (uInches 0.5) = 720.
+ (defun u-round (number &optional (divisor 1))
+ (multiple-value-bind (quotient remainder)
+ (round number divisor)
+ (declare (ignorable remainder))
+ ;(assert (zerop remainder))
+ ;(assert (zerop (mod quotient 15))) ;96ths
+ quotient))
+
+
+ (defun udots (dots dpi)
+ (u-round (* dots logical-dpi) dpi)) ;only the first value will be used.
+
+ (defun uinches (logical-inches)
+ (u-round (* logical-inches logical-dpi))) ;only the first value will be used.
+
+ (defun uin (logical-inches)
+ (uinches logical-inches))
+
+ (defun upoints (logical-points)
+ (udots logical-points 72))
+
+ (defun upts (logical-points)
+ (upoints logical-points))
+
+ (defun u96ths (logical-96ths)
+ (udots logical-96ths 96))
+
+ (defun u8ths (logical-8ths)
+ (udots logical-8ths 8))
+
+ (defun u16ths (logical-16ths)
+ (udots logical-16ths 16))
+
+ (defun u32nds (logical-32nds)
+ (udots logical-32nds 32))
+
+ (defun u120ths (logical-120ths)
+ (udots logical-120ths 120))
+
+ (defun cs-logical-dpi ()
+ logical-dpi)
+
+ (defsetf cs-logical-dpi cs-logical-dpi-setf)
+
+ (defun cs-logical-dpi-setf (new-value)
+ (setf logical-dpi new-value))
+
+ (defun cs-scan-resolution ()
+ scan-resolution)
+
+ (defun cs-logical-screen-resolution ()
+ logical-screen-resolution)
+
+ )
+
+
+
+
+(defmethod u-cvt ((nn number) (units (eql :96ths)) )
+ (u96ths nn))
+
+(defmethod u-cvt ((nn number) (units (eql :8ths)) )
+ (u8ths nn))
+
+(defmethod u-cvt ((nn number) (units (eql :16ths)) )
+ (u16ths nn))
+
+(defmethod u-cvt ((nn number) (units (eql :32nds)) )
+ (u32nds nn))
+
+(defmethod u-cvt ((nn number) (units (eql :inches)) )
+ (uinches nn))
+
+(defmethod u-cvt ((nn number) (units (eql :points)) )
+ (upoints nn))
+
+(defmethod u-cvt (other units)
+ (declare (ignore units))
+ other)
+
+(defmethod u-cvt ((nns cons) units)
+ (cons (u-cvt (car nns) units)
+ (u-cvt (cdr nns) units)))
+
+(defmacro u-cvt! (nn units)
+ `(u-cvt ,nn ,units))
+
+(defun uv2 (x y u-key) (apply #'mkv2 (u-cvt (list x y) u-key)))
+
+;-----------------
+
+(defun os-logical-screen-dpi ()
+ (break "need (win:GetDeviceCaps (device-context (screen *cg-system*)) win:LOGPIXELSX))"))
+
+#+no(defun browser-target-resolution ()
+ (target-resolution (find-window :clinisys)))
+
+; set to 96 because the code is trying to do rect-frames for the header before the window is init'ed.
+
+(let ((current-target-resolution 96)) ;initialize when main window is created
+
+ (defun set-current-target-resolution (resolution)
+ #+shh(trc "setting current-target-resolution to" resolution)
+ (setf current-target-resolution resolution))
+
+ (defun cs-current-target-resolution ()
+ current-target-resolution)
+
+ (defun cs-target-res ()
+ current-target-resolution)
+
+ (defmacro with-target-resolution ((new-resolution) &rest body)
+ (let ((old-resolution (gensym))
+ )
+ `(let ((,old-resolution (cs-current-target-resolution))
+ )
+ (prog2
+ (set-current-target-resolution ,new-resolution)
+ (progn , at body)
+ (set-current-target-resolution ,old-resolution)
+ ))))
+ )
+
+
+;converts screen pixels to logical pixels given the current target resolution OR OPTIONAL OTHER RES
+(defun scr2log (dots &optional (target-res (cs-target-res)))
+ (round (* dots (cs-logical-dpi))
+ target-res))
+
+(defun log2scr (logv &optional (target-res (cs-target-res)))
+ (floor-round (* logv target-res )
+ (cs-logical-dpi)))
+
+(defun cs-archos-dpi ()
+ (cs-logical-dpi))
+
+(defun floor-round (x &optional (divisor 1))
+ (ceiling (- (/ x divisor) 1/2)))
+
+;converts logical pixels to screen pixels given the current target resolution OR OPTIONAL OTHER RES
+(defun logical-to-screen-vector (dots &optional target-res)
+ (let ((convert-res (or target-res (cs-target-res))))
+ (floor-round (* dots convert-res) (cs-logical-dpi))))
+
+(defun logical-to-screen-point (point &optional target-res)
+ (mkv2
+ (log2scr (v2-h point) target-res)
+ (log2scr (v2-v point) target-res)))
+
+(defun screen-to-logical-v2 (point &optional target-res)
+ (mkv2
+ (scr2log (v2-h point) target-res)
+ (scr2log (v2-v point) target-res)))
+
+(defun nr-screen-to-logical (logical-rect screen-rect &optional target-res)
+ (nr-make logical-rect
+ (scr2log (r-left screen-rect) target-res)
+ (scr2log (r-top screen-rect) target-res)
+ (scr2log (r-right screen-rect) target-res)
+ (scr2log (r-bottom screen-rect) target-res)))
+
+; logical-to-target is a more sensible name throughout
+
+(defun logical-to-target-vector (dots &optional target-res)
+ (log2scr dots target-res))
+;--------------------------------------------------------------------------------------------
+
+(defun r-logical-to-screen (logical-rect &optional target-res)
+ (count-it :r-logical-to-screen)
+ (nr-logical-to-screen (mkr 0 0 0 0) logical-rect target-res))
+
+(defun nr-logical-to-screen (screen-rect logical-rect &optional target-res)
+ (nr-make screen-rect
+ (log2scr (r-left logical-rect) target-res)
+ (log2scr (r-top logical-rect) target-res)
+ (log2scr (r-right logical-rect) target-res)
+ (log2scr (r-bottom logical-rect) target-res)))
+
+;------------------------------------------------------------------------------------------------
+
+;;;(defun set-scaling (window)
+;;; #+shh(trc "targetResolution" (targetRes window))
+;;;
+;;; (set-current-target-resolution (cs-logical-screen-resolution)) ;here and below, we'll probably make scalable
+;;; ;(set-current-target-resolution (cs-logical-dpi))
+;;; (let ((dc (device-context window))
+;;; (display-dpi (cs-logical-screen-resolution)) ;... and use (targetRes window)
+;;; (logical-dpi (cs-logical-dpi)))
+;;; (os-SetMapMode dc win:MM_ISOTROPIC)
+;;; (os-SetWindowExtEx dc logical-dpi logical-dpi ct:hnull)
+;;; (os-SetViewportExtEx dc display-dpi display-dpi ct:hnull)))
+
+
+(defun move-v2-x-y (v2 x y)
+ (incf (v2-h v2) x)
+ (incf (v2-v v2) y)
+ v2)
+
+(defmethod ncanvas-to-screen-point (self point)
+ (ncanvas-to-screen-point (fm-parent self)
+ (move-v2-x-y point (px self) (py self))))
+
+(defmethod res-to-res ((amount number) from-res to-res)
+ (if to-res
+ (round (* amount from-res) to-res)
+ from-res))
+
+(defmethod res-to-res ((point v2) from-res to-res)
+ (nres-to-res (copy-v2 point) from-res to-res))
+
+#+no-2e-h
+(defmethod nres-to-res ((point v2) from-res to-res)
+ (setf (v2-h point) (res-to-res (v2-h point) from-res to-res))
+ (setf (v2-v point) (res-to-res (v2-v point) from-res to-res))
+ point)
+
+(defmethod res-to-res ((box rect) from-res to-res)
+ (count-it :res-to-res)
+ (nres-to-res (nr-copy (mkr 0 0 0 0) box) from-res to-res))
+
+(defmethod nres-to-res :around (geo-thing from-res (to-res null))
+ (declare (ignore from-res))
+ geo-thing)
+
+(defmethod nres-to-res ((box rect) from-res to-res)
+ (setf (r-left box) (res-to-res (r-left box) from-res to-res))
+ (setf (r-top box) (res-to-res (r-top box) from-res to-res))
+ (setf (r-right box) (res-to-res (r-right box) from-res to-res))
+ (setf (r-bottom box) (res-to-res (r-bottom box) from-res to-res))
+ box)
+
+(defun canvas-to-screen-box (self box)
+ (count-it :canvas-to-screen-box)
+ (nr-make-from-corners
+ (mkr 0 0 0 0)
+ (ncanvas-to-screen-point self (r-top-left box))
+ (ncanvas-to-screen-point self (r-bottom-right box))))
+
Added: dependencies/trunk/cells/gui-geometry/defpackage.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/defpackage.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,53 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
+#|
+
+Copyright (C) 2004 by Kenneth William 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.
+
+|#
+
+(defpackage #:gui-geometry
+ (:nicknames #:geo)
+ (:use #:common-lisp #:excl #:utils-kt #:cells)
+ (:export #:geometer #:geo-zero-tl #:geo-inline #:a-stack #:a-row
+ #:px #:py #:ll #:lt #:lr #:lb #:pl #:pt #:pr #:pb
+ #:^px #:^py #:^ll #:^lt #:^lr #:^lb #:^lb-height
+ #:^fill-parent-down
+ #:u96ths #:udots #:uinches #:uin #:upoints #:upts #:u8ths #:u16ths #:u32nds
+ #:mkr #:v2-nmove #:l-height #:mkv2 #:^offset-within #:inset-lr #:v2-v #:v2-h
+ #:r-bounds #:l-box
+ #:lb
+ #:cs-target-res
+ #:nr-make
+ #:r-contains
+ #:collapsed
+ #:g-box
+ #:v2-in-rect-ratio
+ #:v2-xlate #:v2-in-rect #:v2-add #:v2-subtract
+ #:log2scr
+ #:^lr-width
+ #:px-maintain-pr
+ #:outset
+ #:py-maintain-pb
+ #:cs-logical-dpi
+ #:px-maintain-pl #:py-maintain-pt
+ #:scr2log
+ #:inset-width #:inset-height
+ #:res-to-res
+ #:logical-to-screen-point
+ #:nres-to-res
+ #:cs-logical-screen-resolution
+ #:outl
+ #:with-r-bounds #:r-inset
+ #:ncopy-rect
+ #:l
+ #:r-height #:r-width #:r-top #:r-right #:r-bottom #:r-left
+ #:l-width ))
Added: dependencies/trunk/cells/gui-geometry/geo-data-structures.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/geo-data-structures.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,342 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
+#|
+
+Copyright (C) 2004 by Kenneth William 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 :gui-geometry)
+
+(eval-now!
+ (export '(v2 mkv2 v2=)))
+;-----------------------------
+
+(defstruct v2
+ (h 0 ) ;; horizontal coordinate
+ (v 0 ) ;; vertical coordinate
+ )
+
+(defmethod print-object ((self v2) s)
+ (format s "~a|~a" (v2-h self)(v2-v self)))
+
+(defun mkv2 (h v) (make-v2 :h h :v v))
+
+(defun v2= (a b)
+ (and a b
+ (= (v2-h a)(v2-h b))
+ (= (v2-v a)(v2-v b))))
+
+(defun v2-add (p1 p2-or-x &optional y-or-p2-or-x-is-p2)
+ (if y-or-p2-or-x-is-p2
+ (make-v2 :h (+ (v2-h p1) p2-or-x)
+ :v (+ (v2-v p1) y-or-p2-or-x-is-p2))
+ (make-v2 :h (+ (v2-h p1) (v2-h p2-or-x))
+ :v (+ (v2-v p1) (v2-v p2-or-x)))))
+
+(defun v2-subtract (p1 p2-or-x &optional y-or-p2-or-x-is-p2)
+ (if y-or-p2-or-x-is-p2
+ (make-v2 :h (- (v2-h p1) p2-or-x)
+ :v (- (v2-v p1) y-or-p2-or-x-is-p2))
+ (make-v2 :h (- (v2-h p1) (v2-h p2-or-x))
+ :v (- (v2-v p1) (v2-v p2-or-x)))))
+
+(defun v2-nmove (p1 x &optional y)
+ (if y
+ (progn
+ (incf (v2-h p1) x)
+ (incf (v2-v p1) y))
+ (v2-nmove p1 (v2-h x)(v2-v x)))
+ p1)
+
+(defun v2-in-rect (v2 r)
+ (mkv2 (min (r-right r) (max (r-left r) (v2-h v2)))
+ (min (r-top r) (max (r-bottom r) (v2-v v2)))))
+
+(defun v2-in-rect-ratio (v2 r)
+ (assert (<= (r-left r) (v2-h v2) (r-right r)))
+ (assert (<= (r-bottom r) (v2-v v2) (r-top r)))
+ (mkv2 (div-safe (- (v2-h v2) (r-left r)) (r-width r))
+ (div-safe (- (v2-v v2) (r-bottom r)) (r-height r))))
+
+(defun div-safe (n d &optional (zero-div-return-value 1))
+ (if (zerop d) zero-div-return-value (/ n d)))
+
+(defmethod c-value-incf (c (base v2) (delta number))
+ (declare (ignore c))
+ (mkv2 (+ (v2-h base) delta)
+ (+ (v2-v base) delta)))
+
+(defmethod c-value-incf (c (base v2) (delta v2))
+ (declare (ignore c))
+ (v2-add base delta))
+
+; synapse support
+;
+(defmethod delta-diff ((new v2) (old v2) (subtypename (eql 'v2)))
+ (v2-subtract new old))
+
+(defmethod delta-identity ((dispatcher number) (subtypename (eql 'v2)))
+ (mkv2 0 0))
+
+(defun long-v2 (long-hv)
+ (c-assert (numberp long-hv))
+ (multiple-value-bind (fv fh)
+ (floor long-hv 65536)
+ (mkv2 fh fv)))
+
+(defun long-x (long-hv)
+ (c-assert (numberp long-hv))
+ (mod long-hv 65536))
+
+(defun long-y (long-hv)
+ (c-assert (numberp long-hv))
+ (floor long-hv 65536))
+
+(defun v2-long (v2)
+ (c-assert (typep v2 'v2))
+ (xy-long (v2-h v2) (v2-v v2)))
+
+(defun xy-long (x y)
+ (+ (* 65536 y) x))
+
+(defun v2-to-vector (v2)
+ (vector (v2-h v2) (v2-v v2)))
+
+(defun v2-negative (v2)
+ (c-assert (typep v2 'v2))
+ (mkv2 (- (v2-h v2)) (- (v2-v v2))))
+
+(defun vector-v2 (vc) (mkv2 (elt vc 0) (elt vc 1)))
+
+(defmethod delta-exceeds ((d1 v2) (d2 v2) (subtypename (eql 'v2)))
+ (c-assert (and (typep d1 'v2) (typep d2 'v2)))
+ (> (v2-distance-to d1) (v2-distance-to d2)))
+
+(defun v2-distance (from to)
+ (sqrt (+ (expt (v2-dv from to) 2)
+ (expt (v2-dh from to) 2))))
+
+(defun v2-area (v2)
+ "Treat point as length & width and calc area"
+ (abs (* (v2-h v2)(v2-v v2))))
+
+(defun v2-dh (p1 p2)
+ (- (v2-h p2) (v2-h p1)))
+
+(defun v2-dv (p1 p2)
+ (- (v2-v p2) (v2-v p1)))
+
+(defun v2-angle-between (from to)
+ (atan (v2-dv from to) (v2-dh from to)))
+
+(defun v2-distance-to (to)
+ (sqrt (+ (expt (v2-h to) 2)
+ (expt (v2-v to) 2))))
+;-------------------------------------------------
+
+(export! rect)
+(defstruct (rect (:conc-name r-))
+ (left 0 )
+ (top 0 )
+ (right 0 )
+ (bottom 0 ))
+
+(defmethod print-object ((self rect) s)
+ (format s "(rect (~a,~a) (~a,~a))" (r-left self)(r-top self)(r-right self)(r-bottom self)))
+
+(defun r-top-left (r)
+ (mkv2 (r-left r) (r-top r)))
+
+(export! r-center)
+
+(defun r-center (r)
+ (mkv2 (/ (+ (r-left r)(r-right r)) 2)
+ (/ (+ (r-top r)(r-bottom r)) 2)))
+
+(defun r-bottom-right (r)
+ (mkv2 (r-bottom r) (r-right r)))
+
+(defun mkr (left top right bottom)
+ (count-it :mkrect)
+ (make-rect :left left :top top :right right :bottom bottom))
+
+(defun nr-make (r left top right bottom)
+ (setf (r-left r) left (r-top r) top (r-right r) right (r-bottom r) bottom)
+ r)
+
+(defmacro with-r-bounds ((lv tv rv bv) r-form &body body)
+ (let ((r (gensym)))
+ `(let* ((,r ,r-form)
+ (,lv (r-left ,r))
+ (,tv (r-top ,r))
+ (,rv (r-right ,r))
+ (,bv (r-bottom ,r)))
+ , at body)))
+
+(defun ncopy-rect (old &optional new)
+ (if new
+ (progn
+ (setf (r-left new)(r-left old)
+ (r-top new)(r-top old)
+ (r-right new)(r-right old)
+ (r-bottom new)(r-bottom old))
+ new)
+ (copy-rect old)))
+
+(defun r-inset (r in &optional (destr (mkr 0 0 0 0)))
+ (nr-make destr
+ (+ (r-left r) in)
+ (+ (r-top r) (downs in))
+ (- (r-right r) in)
+ (+ (r-bottom r) (ups in))))
+
+(defun nr-make-from-corners (r tl br)
+ (nr-make r (v2-h tl)(v2-v tl)(v2-h br)(v2-v br)))
+
+(defun nr-copy (r copied-r)
+ (setf (r-left r) (r-left copied-r)
+ (r-top r) (r-top copied-r)
+ (r-right r) (r-right copied-r)
+ (r-bottom r) (r-bottom copied-r))
+ r)
+
+(defun r-contains (r v2)
+ (and (<= (r-left r)(v2-h v2)(r-right r))
+ (<= (r-top r)(v2-v v2)(r-bottom r))))
+
+(defun nr-intersect (r sr)
+ (let ((r-min-v (min (r-top r) (r-bottom r)))
+ (r-max-v (max (r-top r) (r-bottom r)))
+ (r-min-h (min (r-left r) (r-right r)))
+ (r-max-h (max (r-left r) (r-right r)))
+ ;
+ (sr-min-v (min (r-top sr) (r-bottom sr)))
+ (sr-max-v (max (r-top sr) (r-bottom sr)))
+ (sr-min-h (min (r-left sr) (r-right sr)))
+ (sr-max-h (max (r-left sr) (r-right sr)))
+ )
+ (let ((min-v (max r-min-v sr-min-v))
+ (max-v (min r-max-v sr-max-v))
+ (min-h (max r-min-h sr-min-h))
+ (max-h (min r-max-h sr-max-h)))
+ (when (or (>= min-v max-v)(>= min-h max-h))
+ (setf min-h 0 min-v 0 max-h 0 max-v 0))
+ (nr-make r min-h min-v max-h max-v))))
+
+(defun nr-union (r sr) ;; unlike other code, this is assuming opengl's up==plus, and proper rectangles
+ (nr-make r (min (r-left r) (r-left sr))
+ (max (r-top r) (r-top sr))
+ (max (r-right r) (r-right sr))
+ (min (r-bottom r) (r-bottom sr))))
+
+(defun nr-move-to (r h v)
+ (setf (r-left r) h
+ (r-top r) (+ v (r-width r))
+ (r-right r) (+ h (r-width r))
+ (r-bottom r) (+ v (r-height r))))
+
+
+(defun nr-scale (r factor)
+ (nr-make r
+ (round (* (r-left r) factor))
+ (round (* (r-top r) factor))
+ (round (* (r-right r) factor))
+ (round (* (r-bottom r) factor))))
+
+(defun r-empty (r)
+ (or (zerop (r-width r))
+ (zerop (r-height r))))
+
+(defun r-width (r) (abs (- (r-right r)(r-left r))))
+(defun r-height (r) (abs (- (r-top r)(r-bottom r))))
+(defun r-area (r) (* (r-width r)(r-height r)))
+
+(defun nr-offset (r dh dv)
+;;; (declare (optimize (speed 3) (safety 0) (debug 0)))
+ ;; (declare (type fixnum dh dv))
+ (incf (r-left r) dh)
+ (incf (r-right r) dh)
+ (incf (r-top r) dv)
+ (incf (r-bottom r) dv)
+ r)
+
+(defun nr-outset (box dh &optional (dv dh))
+;;; (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (declare (type fixnum dh dv))
+ (decf (r-left box) dh)
+ (incf (r-right box) dh)
+ (decf (r-top box) dv)
+ (incf (r-bottom box) dv)
+ box)
+
+(defun r-bounds (box)
+ (list (r-left box)(r-top box)(r-right box)(r-bottom box)))
+
+(defun pt-in-bounds (point bounds-left bounds-top bounds-right boundsbottom)
+;;; (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (declare (type fixnum bounds-left bounds-top bounds-right boundsbottom))
+ (and (<= bounds-left (progn (v2-h point)) bounds-right)
+ (<= bounds-top (progn (v2-v point)) boundsbottom)))
+
+
+(defun r-in-bounds (box bounds-left bounds-top bounds-right boundsbottom)
+;;; (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (declare (type fixnum bounds-left bounds-top bounds-right boundsbottom))
+ (and (<= bounds-left (progn (r-left box)) (progn (r-right box)) bounds-right)
+ (<= bounds-top (progn (r-top box)) (progn (r-bottom box)) boundsbottom)))
+
+(defun r-unitize (object-r unit-r &aux (ww (r-width unit-r))(wh (r-height unit-r)))
+ (flet ((cf (i) (coerce i 'float)))
+ (mkr (cf (/ (- (r-left object-r)(r-left unit-r)) ww))
+ (cf (/ (- (r-top unit-r)(r-top object-r)) wh))
+ (cf (/ (- (r-right object-r)(r-left unit-r)) ww))
+ (cf (/ (- (r-top unit-r)(r-bottom object-r)) wh)))))
+
+(defun r-scale (r x y)
+ (mkr (* (r-left r) x)
+ (* (r-top r) y)
+ (* (r-right r) x)
+ (* (r-bottom r) x)))
+
+(defun r-analog (this1 that1 this2)
+ (mkr (* (r-left this2) (/ (r-left that1)(r-left this1)))
+ (* (r-top this2) (/ (r-top that1)(r-top this1)))
+ (* (r-right this2) (/ (r-right that1)(r-right this1)))
+ (* (r-bottom this2) (/ (r-bottom that1)(r-bottom this1)))))
+
+
+;;; --- Up / Down variability management ---
+
+(eval-now!
+ (export '(*up-is-positive* ups ups-more ups-most downs downs-most downs-more)))
+
+(defparameter *up-is-positive* t
+ "You should set this to NIL for most GUIs, but not OpenGl")
+
+(defun ups (&rest values)
+ (apply (if *up-is-positive* '+ '-) values))
+
+(defun ups-more (&rest values)
+ (apply (if *up-is-positive* '> '<) values))
+
+(defun ups-most (&rest values)
+ (apply (if *up-is-positive* 'max 'min) values))
+
+(defun downs (&rest values)
+ (apply (if *up-is-positive* '- '+) values))
+
+(defun downs-most (&rest values)
+ (apply (if *up-is-positive* 'min 'max) values))
+
+(defun downs-more (&rest values)
+ (apply (if *up-is-positive* '< '>) values))
+
Added: dependencies/trunk/cells/gui-geometry/geo-family.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/geo-family.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,171 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
+#|
+
+Copyright (C) 2004 by Kenneth William 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 :gui-geometry)
+
+(export! geo-inline-lazy ^px-self-centered justify py-maintain-pt
+ ^prior-sib-pb spacing lr-maintain-pr orientation)
+
+;--------------- geo-inline -----------------------------
+;
+(defmodel geo-inline (geo-zero-tl)
+ ((orientation :initarg :orientation :initform nil :accessor orientation
+ :documentation ":vertical (for a column) or :horizontal (row)")
+ (justify :initarg :justify :accessor justify
+ :initform (c? (ecase (orientation self)
+ (:vertical :left)
+ (:horizontal :top))))
+ (spacing :initarg :spacing :initform 0 :accessor spacing))
+ (:default-initargs
+ :lr (c? (if (^collapsed)
+ (^lr-width 0)
+ (+ (^outset)
+ (ecase (orientation self)
+ (:vertical (loop for k in (^kids)
+ maximizing (l-width k)))
+ (:horizontal (bif (lk (last1 (^kids)))
+ (pr lk) 0))))))
+ :lb (c? (if (^collapsed)
+ (^lb-height 0)
+ (+ (- (^outset))
+ (ecase (orientation self)
+ (:vertical (loop for k in (^kids)
+ unless (collapsed k)
+ minimizing (pb k)))
+ (:horizontal (downs (loop for k in (^kids)
+ maximizing (l-height k))))))))
+ :kid-slots (lambda (self)
+ (ecase (orientation .parent)
+ (:vertical (list
+ (mk-kid-slot (px :if-missing t)
+ (c? (^px-self-centered (justify .parent))))
+ (mk-kid-slot (py)
+ (c? (py-maintain-pt
+ (^prior-sib-pb self (spacing .parent)))))))
+ (:horizontal (list
+ (mk-kid-slot (py :if-missing t)
+ (c? (py-self-centered self (justify .parent))))
+ (mk-kid-slot (px :if-missing t)
+ (c? (px-maintain-pl
+ (^prior-sib-pr self (spacing .parent)))))))))
+ ))
+
+(defmodel geo-inline-lazy (geo-zero-tl)
+ ((orientation :initarg :orientation :initform nil :accessor orientation
+ :documentation ":vertical (for a column) or :horizontal (row)")
+ (justify :initarg :justify :accessor justify
+ :initform (c_? (ecase (orientation self)
+ (:vertical :left)
+ (:horizontal :top))))
+ (spacing :initarg :spacing :initform 0 :accessor spacing))
+ (:default-initargs
+ :lr (c_? (+ (^outset)
+ (ecase (orientation self)
+ (:vertical (loop for k in (^kids)
+ maximizing (l-width k)))
+ (:horizontal (bif (lk (last1 (^kids)))
+ (pr lk) 0)))))
+ :lb (c_? (+ (- (^outset))
+ (ecase (orientation self)
+ (:vertical (bif (lk (last1 (^kids)))
+ (pb lk) 0))
+ (:horizontal (downs (loop for k in (^kids)
+ maximizing (l-height k)))))))
+ :kid-slots (lambda (self)
+ (ecase (orientation .parent)
+ (:vertical (list
+ (mk-kid-slot (px :if-missing t)
+ (c_? (^px-self-centered (justify .parent))))
+ (mk-kid-slot (py)
+ (c_? (eko (nil "py" self (^lt) (l-height self)(psib))
+ (py-maintain-pt
+ (eko (nil "psib-pb")
+ (^prior-sib-pb self (spacing .parent)))))))))
+ (:horizontal (list
+ (mk-kid-slot (py :if-missing t)
+ (c_? (py-self-centered self (justify .parent))))
+ (mk-kid-slot (px)
+ (c_? (px-maintain-pl
+ (^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 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 kn upfrom 0
+ for kw = (or (^fixed-col-width) (l-width k))
+ for kpr = (+ pl kw)
+ when (unless (= pl 0)
+ (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 (case (justify self)
+ (:center (/ (- kw (l-width k)) 2))
+ (:right (- kw (l-width k)))
+ (otherwise 0))) pt) into pxys
+ 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))
+ (car xys) 0)
+ (downs (outset self))))
+ :kid-slots (lambda (self)
+ (declare (ignore self))
+ (list
+ (mk-kid-slot (px)
+ (c? (px-maintain-pl (car (nth (kid-no self) (cdr (row-flow-layout .parent)))))))
+ (mk-kid-slot (py)
+ (c? (py-maintain-pt (cdr (nth (kid-no self) (cdr (row-flow-layout .parent))))))))))
+
+
+
+
+
+
Added: dependencies/trunk/cells/gui-geometry/geo-macros.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/geo-macros.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,142 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
+#|
+
+Copyright (C) 2004 by Kenneth William 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 #:gui-geometry)
+
+(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))))))
+
+(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))
+
+(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)))
+
+(export! centered-h? centered-v? lb-maintain-pB)
+
+(defmacro ^fill-down (upper-type &optional (padding 0))
+ (let ((filled (gensym)))
+ `(let ((,filled (upper self ,upper-type)))
+ #+shhh (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))))
+
+; "...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))))))
+
+(defmacro ^fill-parent-right (&optional (inset 0))
+ `(lr-maintain-pr (- (inset-lr .parent) ,inset)))
+
+(defmacro ^fill-parent-down ()
+ `(lb-maintain-pb (inset-lb .parent)))
+
+(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))))
+
+
+
Added: dependencies/trunk/cells/gui-geometry/geometer.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/geometer.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,241 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
+#|
+
+Copyright (C) 2004 by Kenneth William 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 #:gui-geometry)
+
+(eval-now!
+ (export '(outset ^outset mkv2 g-offset g-offset-h g-offset-v collapsed ^collapsed inset ^inset)))
+
+(defmd geometer ()
+ px py ll lt lr lb
+ collapsed
+ (inset (mkv2 0 0) :unchanged-if 'v2=)
+ (outset 0)
+ (w-box (mkr 0 0 0 0) :cell nil :accessor w-box
+ :documentation "bbox in window coordinate system"))
+
+(defmethod collapsed (other)
+ (declare (ignore other))
+ nil)
+
+;;-------- Zero-zero Top Left ----------------------------
+;;
+(defmodel geo-zero-tl (family)
+ ()
+ (:default-initargs
+ :ll (c? (- (outset self)))
+ :lt (c? (+ (outset self)))
+ :lr (c? (geo-kid-wrap self 'pr))
+ :lb (c? (geo-kid-wrap self 'pb))
+ :kid-slots (def-kid-slots
+ (mk-kid-slot (px :if-missing t)
+ (c? (px-maintain-pl 0)))
+ (mk-kid-slot (py :if-missing t)
+ (c? (py-maintain-pt 0))))))
+
+(export! geo-kid-sized)
+(defmodel geo-kid-sized (family)
+ ()
+ (:default-initargs
+ :ll (c? (geo-kid-wrap self 'pl))
+ :lt (c? (geo-kid-wrap self 'pt))
+ :lr (c? (geo-kid-wrap self 'pr))
+ :lb (c? (geo-kid-wrap self 'pb))))
+
+(defun l-box (geo)
+ (count-it :l-box)
+ (mkr (ll geo) (lt geo) (lr geo) (lb geo)))
+
+;---------- gOffset -------------------
+
+(export! offset-within inset-lb)
+;
+(defun offset-within (inner outer &optional dbg)
+ (declare (ignorable dbg))
+ (trc nil "offset-within inner outer" inner outer)
+ (do (
+ (offset-h 0 (progn
+ (trc nil "offset-within delta-h, from" from (px from))
+ (incf offset-h (px from))))
+ (offset-v 0 (incf offset-v (py from)))
+ (from inner (fm-parent from)))
+ ((or (null from)
+ (null outer)
+ (eql from outer)) (eko (nil "offset-within returns")
+ (mkv2 offset-h offset-v)))))
+
+(defun offset-within2 (inner outer)
+ (do (
+ (offset-h 0 (incf offset-h (px from)))
+ (offset-v 0 (incf offset-v (py from)))
+ (from inner (fm-parent from)))
+ ((or (null from)
+ (null outer)
+ (eql from outer)) (mkv2 offset-h offset-v))
+ ;(trc "inner outer" inner outer)
+ ))
+
+
+
+;----------- OfKids -----------------------
+;
+
+(defun v2-in-subframe (super h v sub)
+ (if (eql super sub) ;; bingo
+ (values h v)
+ (dolist (kid (kids super))
+ (multiple-value-bind (subh sub-v)
+ (v2-in-subframe kid h v sub)
+ (when subh
+ (return-from v2-in-subframe (values (- subh (px kid))
+ (- sub-v (py kid)))))))))
+(defun mk-gr (geo)
+ (c-assert geo)
+ (count-it :mk-gr)
+ (let ((g-offset (g-offset geo))) ;; /// wastes a v2
+ (nr-offset (mkr (ll geo) (lt geo) (lr geo) (lb geo)) (v2-h g-offset) (v2-v g-offset))))
+
+;sum pXYs up the family tree ;gave an odd result for cursor display....
+
+(defun v2-xlate (outer inner outer-v2)
+ (if (eq outer inner)
+ outer-v2
+ (v2-xlate outer (fm-parent inner)
+ (v2-subtract outer-v2
+ (mkv2 (px inner) (py inner))))))
+
+(defun v2-xlate-out (inner outer inner-v2)
+ (if (eq outer inner)
+ inner-v2
+ (v2-xlate (fm-parent inner) outer
+ (v2-add inner-v2
+ (mkv2 (px inner) (py inner))))))
+
+(defun v2-xlate-between (from-v2 from to)
+ (cond
+ ((fm-includes from to)(v2-xlate from to from-v2))
+ ((fm-includes to from)(v2-xlate-out from to from-v2))
+ (t (break "time to extend v2-xlate-between"))))
+
+(export! h-xlate v-xlate v2-xlate-between)
+
+(defun h-xlate (outer inner outer-h)
+ (if (eql outer inner)
+ outer-h
+ (h-xlate outer (fm-parent inner)
+ (- outer-h (px inner)))))
+
+(defun v-xlate (outer inner outer-v)
+ (if (eql outer inner)
+ outer-v
+ (v-xlate outer (fm-parent inner)
+ (- outer-v (py inner)))))
+
+(defmethod g-offset (self &optional (accum-h 0) (accum-v 0) within)
+ (declare (ignorable self within))
+ (mkv2 accum-h accum-v))
+
+(defun g-offset-h (geo)
+ (v2-h (g-offset geo)))
+
+(defun g-offset-v (geo)
+ (v2-v (g-offset geo)))
+
+(defun g-box (geo)
+ (count-it :g-box)
+ (if (c-stopped)
+ (trc "gbox sees stop" geo)
+ (progn
+ (c-assert geo)
+ (let* ((g-offset (g-offset geo))
+ (oh (v2-h g-offset)))
+ (c-assert (typep g-offset 'v2))
+ (c-assert (numberp oh))
+ (c-assert (numberp (lr geo)))
+ (let ((r (nr-offset
+ (nr-make (w-box geo) (ll geo) (lt geo) (lr geo) (lb geo))
+ oh (v2-v g-offset))))
+ (c-assert (numberp (r-left r)))
+ (c-assert (numberp (r-top r)))
+ (c-assert (numberp (r-right r)))
+ (c-assert (numberp (r-bottom r)))
+ r)))))
+
+;____________________________________________
+
+(defun pl (self) (+ (px self) (ll self)))
+(defun pr (self)
+ (c-assert (px self))
+ (c-assert (lr self))
+ (+ (px self) (lr self)))
+(defun pt (self) (+ (py self) (lt self)))
+(defun pb (self)
+ (c-assert (lb self))
+ (c-assert (py self))
+ (+ (py self) (lb self)))
+
+(defun pxy (self)
+ (mkv2 (px self) (py self)))
+
+;--------------------------------------------------------
+
+
+(defun l-width (i)
+ (c-assert (lr i))
+ (c-assert (ll i))
+ (- (lr i) (ll i)))
+
+(defun l-height (i)
+ (abs (- (lb i) (lt i))))
+
+;;-----------------------------------------------
+
+(defun inset-width (self)
+ (- (l-width self) (outset self) (outset self)))
+
+(defun inset-lr (self)
+ (- (lr self) (outset self)))
+
+(defun inset-lb (self)
+ (+ (lb self) (outset self)))
+
+(defun inset-lt (self)
+ (downs (lt self) (outset self)))
+
+(defun inset-height (self)
+ (- (l-height self) (outset self) (outset self)))
+
+;---------------------------------
+
+;----------------------------------
+
+(export! geo-kid-wrap inset-lt)
+
+(defun geo-kid-wrap (self bound)
+ (funcall (ecase bound ((pl pb) '-)((pr pt) '+))
+ (funcall (ecase bound
+ ((pl pb) 'fm-min-kid)
+ ((pr pt) 'fm-max-kid)) self bound)
+ (outset self)))
+
+; in use; same idea for pT
+(defun py-self-centered (self justify)
+ (py-maintain-pt
+ (ecase justify
+ (:top 0)
+ (:center (floor (- (inset-height .parent) (l-height self)) -2))
+ (:bottom (downs (- (inset-height .parent) (l-height self)))))))
+
Added: dependencies/trunk/cells/gui-geometry/gui-geometry.asd
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/gui-geometry.asd Tue Jan 26 15:20:07 2010
@@ -0,0 +1,15 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+
+(asdf:defsystem :gui-geometry
+ :author "Kenny Tilton <kentilton at gmail.com>"
+ :maintainer "Kenny Tilton <kentilton at gmail.com>"
+ :licence "Lisp LGPL"
+ :depends-on (:cells)
+ :serial t
+ :components
+ ((:file "defpackage")
+ (:file "geo-macros")
+ (:file "geo-data-structures")
+ (:file "coordinate-xform")
+ (:file "geometer")
+ (:file "geo-family")))
Added: dependencies/trunk/cells/gui-geometry/gui-geometry.lpr
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/gui-geometry.lpr Tue Jan 26 15:20:07 2010
@@ -0,0 +1,88 @@
+;; -*- lisp-version: "8.0 [Windows] (Jan 29, 2007 18:02)"; cg: "1.81"; -*-
+
+(in-package :cg-user)
+
+(defpackage :COMMON-GRAPHICS-USER)
+
+(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")
+ (make-instance 'module :name "geometer.lisp")
+ (make-instance 'module :name "geo-family.lisp"))
+ :projects (list (make-instance 'project-module :name
+ "..\\..\\Cells\\cells"))
+ :libraries nil
+ :distributed-files nil
+ :internally-loaded-files nil
+ :project-package-name :common-graphics-user
+ :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)
+ :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)
+ :autoload-warning t
+ :full-recompile-for-runtime-conditionalizations nil
+ :default-command-line-arguments "+M +t \"Console for Debugging\""
+ :additional-build-lisp-image-arguments '(:read-init-files nil)
+ :old-space-size 256000
+ :new-space-size 6144
+ :runtime-build-option :standard
+ :on-initialization 'default-init-function
+ :on-restart 'do-default-restart)
+
+;; End of Project Definition
Added: dependencies/trunk/cells/initialize.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/initialize.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,63 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+(eval-when (compile eval load)
+ (export '(c-envalue)))
+
+(defstruct (c-envaluer (:conc-name nil))
+ envalue-rule)
+
+(defmethod awaken-cell (c)
+ (declare (ignorable c)))
+
+(defmethod awaken-cell ((c cell))
+ (assert (c-inputp c))
+ ;
+ ; nothing to calculate, but every cellular slot should be output
+ ;
+ (trc nil "awaken cell observing" c)
+ (when (> *data-pulse-id* (c-pulse-observed c))
+ (setf (c-pulse-observed c) *data-pulse-id*)
+ (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil c)
+ (ephemeral-reset c)))
+
+(defmethod awaken-cell ((c c-ruled))
+ (let (*depender*)
+ (calculate-and-set c :fn-awaken-cell nil)))
+
+#+cormanlisp ; satisfy CormanCL bug
+(defmethod awaken-cell ((c c-dependent))
+ (let (*depender*)
+ (trc nil "awaken-cell c-dependent clearing *depender*" c)
+ (calculate-and-set c :fn-awaken-cell nil)))
+
+(defmethod awaken-cell ((c c-drifter))
+ ;
+ ; drifters *begin* valid, so the derived version's test for unbounditude
+ ; would keep (drift) rule ever from being evaluated. correct solution
+ ; (for another day) is to separate awakening (ie, linking to independent
+ ; cs) from evaluation, tho also evaluating if necessary during
+ ; awakening, because awakening's other role is to get an instance up to speed
+ ; at once upon instantiation
+ ;
+ (calculate-and-set c :fn-awaken-cell nil)
+ (cond ((c-validp c) (c-value c))
+ ((c-unboundp c) nil)
+ (t "illegal state!!!")))
Added: dependencies/trunk/cells/integrity.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/integrity.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,234 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+(define-constant *ufb-opcodes* '(:tell-dependents
+ :awaken
+ :client
+ :ephemeral-reset
+ :change))
+
+(defmacro with-integrity ((&optional opcode defer-info debug) &rest body)
+ (declare (ignorable debug))
+ (when opcode
+ (assert (find opcode *ufb-opcodes*) ()
+ "Invalid opcode for with-integrity: ~a. Allowed values: ~a" opcode *ufb-opcodes*))
+ `(call-with-integrity ,opcode ,defer-info
+ (lambda (opcode defer-info)
+ (declare (ignorable opcode defer-info))
+ ;;; ,(when debug
+ ;;; `(trc "integrity action entry" opcode defer-info ',body))
+ ;;; (when *c-debug*
+ ;;; (when (eq opcode :change)
+ ;;; (trc "-------w/integ :change go--------------->:" defer-info)))
+ , at body)
+ nil
+ #+noway (when *c-debug* ',body)))
+
+(export! with-cc)
+
+(defmacro with-cc (id &body body)
+ `(with-integrity (:change ,id)
+ , at body))
+
+(defun integrity-managed-p ()
+ *within-integrity*)
+
+(defun call-with-integrity (opcode defer-info action code)
+ (declare (ignorable code))
+ (when *stop*
+ (return-from call-with-integrity))
+ (if *within-integrity*
+ (if opcode
+ (prog1
+ :deferred-to-ufb-1 ; SETF is supposed to return the value being installed
+ ; in the place, but if the SETF is deferred we return
+ ; something that will help someone who tries to use
+ ; the setf'ed value figure out what is going on:
+ (ufb-add opcode (cons defer-info action)))
+
+ ; thus by not supplying an opcode one can get something
+ ; executed immediately, potentially breaking data integrity
+ ; but signifying by having coded the with-integrity macro
+ ; that one is aware of this. If you read this comment.
+ (funcall action opcode defer-info))
+
+ (flet ((go-go ()
+ (let ((*within-integrity* t)
+ *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)
+ (data-pulse-next (cons opcode defer-info))))
+ (prog1
+ (funcall action opcode defer-info)
+ (setf *finbiz-id* 0)
+ (finish-business)))))
+ (if nil ;; *c-debug*
+ (let ((*istack* (list (list opcode defer-info)
+ (list :trigger code)
+ (list :start-dp *data-pulse-id*))))
+ (trc "*istack* bound")
+ (handler-case
+ (go-go)
+ (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")))))
+ (trc "*istack* unbinding"))
+ (go-go)))))
+
+(defun ufb-queue (opcode)
+ (cdr (assoc opcode *unfinished-business*)))
+
+(defun ufb-queue-ensure (opcode)
+ (or (ufb-queue opcode)
+ (cdr (car (push (cons opcode (make-fifo-queue)) *unfinished-business*)))))
+
+(defparameter *no-tell* nil)
+
+(defun ufb-add (opcode continuation)
+ #+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))
+
+(defun just-do-it (op-or-q &optional (op-code op-or-q) ;; [mb]
+ &aux (q (if (keywordp op-or-q)
+ (ufb-queue op-or-q)
+ op-or-q)))
+ (declare (ignorable op-code))
+ (trc nil "----------------------------just do it doing---------------------" op-or-q)
+ (loop for (defer-info . task) = (fifo-pop q)
+ while task
+ do (trc nil "unfin task is" opcode task)
+ #+chill (when *c-debug*
+ (push (list op-code defer-info) *istack*))
+ (funcall task op-or-q defer-info)))
+
+(defun finish-business ()
+ (when *stop* (return-from finish-business))
+ (incf *finbiz-id*)
+ (tagbody
+ tell-dependents
+ (just-do-it :tell-dependents)
+ ;
+ ; while the next step looks separate from the prior, they are closely bound.
+ ; during :tell-dependents, any number of new model instances can be spawned.
+ ; as they are spawned, shared-initialize queues them for awakening, which
+ ; you will recall forces the calculation of ruled cells and observer notification
+ ; for all cell slots. These latter may enqueue :change or :client tasks, in which
+ ; case note that they become appended to :change or :client tasks enqueued
+ ; during :tell-dependents. How come? Because the birth itself of model instances during
+ ; a datapulse is considered part of that datapulse, so we do want tasks enqueued
+ ; during their awakening to be handled along with those enqueued by cells of
+ ; existing model instances.
+ ;
+ #-its-alive!
+ (bwhen (uqp (fifo-peek (ufb-queue :tell-dependents)))
+ (trcx fin-business uqp)
+ (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 ---
+ )
+ ;
+ ; 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)))
+ #+xxx (trc "retelling dependenst, one new one being" uqp)
+ (go tell-dependents))
+
+ ;--- process client queue ------------------------------
+ ;
+ (when *stop* (return-from finish-business))
+
+ handle-clients
+ (bwhen (clientq (ufb-queue :client))
+ (if *client-queue-handler*
+ (funcall *client-queue-handler* clientq) ;; might be empty/not exist, so handlers must check
+ (just-do-it clientq :client))
+ (when (fifo-peek (ufb-queue :client))
+ #+shhh (ukt::fifo-browse (ufb-queue :client) (lambda (entry)
+ (trc "surprise client" entry)))
+ (go handle-clients)))
+ ;--- now we can reset ephemerals --------------------
+ ;
+ ; one might be wondering when the observers got notified. That happens right during
+ ; slot.value.assume, via c-propagate.
+ ;
+ ; Nice historical note: by accident, in the deep-cells test to exercise the new behavior
+ ; of cells3, I coded an ephemeral cell and initialized it to non-nil, hitting a runtime
+ ; error (now gone) saying I had no idea what a non-nil ephemeral would mean. That had been
+ ; my conclusion when the idea occurred to me the first time, so I stuck in an assertion
+ ; to warn off callers.
+ ;
+ ; But the new
+ ; datachange progression defined by Cells3 had already forced me to manage ephemeral resets
+ ; more predictably (something in the test suite failed). By the time I got the runtime
+ ; error on deep-cells I was able to confidently take out the error and just let the thing
+ ; run. deep-cells looks to behave just right, but maybe a tougher test will present a problem?
+ ;
+ (just-do-it :ephemeral-reset)
+
+ ;--- do deferred state changes -----------------------
+ ;
+ (bwhen (task-info (fifo-pop (ufb-queue :change)))
+ (trc nil "!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change)))
+ (destructuring-bind (defer-info . task-fn) task-info
+ #+xxx (trc "fbz: dfrd chg" defer-info (fifo-length (ufb-queue :change)))
+ (data-pulse-next (list :finbiz defer-info))
+ (funcall task-fn :change defer-info)
+ ;
+ ; to finish this state change we could recursively call (finish-business), but
+ ; a goto let's us not use the stack. Someday I envision code that keeps on
+ ; setf-ing, polling the OS for events, in which case we cannot very well use
+ ; recursion. But as a debugger someone might want to change the next form
+ ; to (finish-business) if they are having trouble with a chain of setf's and
+ ; want to inspect the history on the stack.
+ ;
+ (go tell-dependents)))))
+
+
Added: dependencies/trunk/cells/link.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/link.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,152 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+(defun record-caller (used)
+ (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell
+ (trc nil "depender not being recorded because used optimized away" *depender* (c-value used) :used used)
+ (return-from record-caller nil))
+ #+shhh (trc *depender* "record-caller depender entry: used=" used :caller *depender*)
+ (assert *depender*)
+ #+shhh (trc used "record-caller caller entry: used=" (qci used)
+ :caller *depender*)
+
+ (multiple-value-bind (used-pos useds-len)
+ (loop with u-pos
+ for known in (cd-useds *depender*)
+ counting known into length
+ when (eq used known)
+ do
+ (count-it :known-used)
+ (setf u-pos length)
+ finally (return (values (when u-pos (- length u-pos)) length)))
+
+ (when (null used-pos)
+ (trc nil "c-link > new caller,used " *depender* used)
+ (count-it :new-used)
+ (setf used-pos useds-len)
+ (push used (cd-useds *depender*))
+ (caller-ensure used *depender*) ;; 060604 experiment was in unlink
+ )
+ (let ((cd-usage (cd-usage *depender*)))
+ (when (>= used-pos (array-dimension cd-usage 0))
+ (setf cd-usage
+ (setf (cd-usage *depender*)
+ (adjust-array (cd-usage *depender*)
+ (+ used-pos 16)
+ :initial-element 0))))
+ (setf (sbit cd-usage used-pos) 1))
+ #+nonportable
+ (handler-case
+ (setf (sbit (cd-usage *depender*) used-pos) 1)
+ (type-error (error)
+ (declare (ignorable error))
+ (setf (cd-usage *depender*)
+ (adjust-array (cd-usage *depender*) (+ used-pos 16) :initial-element 0))
+ (setf (sbit (cd-usage *depender*) used-pos) 1))))
+ used)
+
+
+;--- unlink unused --------------------------------
+
+(defun c-unlink-unused (c &aux (usage (cd-usage c))
+ (usage-size (array-dimension (cd-usage c) 0))
+ (dbg nil))
+ (declare (ignorable dbg usage-size))
+ (when (cd-useds c)
+ (let (rev-pos)
+ (labels ((nail-unused (useds)
+ (flet ((handle-used (rpos)
+ (if (or (>= rpos usage-size)
+ (zerop (sbit usage rpos)))
+ (progn
+ (count-it :unlink-unused)
+ (trc nil "c-unlink-unused" c :dropping-used (car useds))
+ (c-unlink-caller (car useds) c)
+ (rplaca useds nil))
+ (progn
+ ;; moved into record-caller 060604 (caller-ensure (car useds) c)
+ )
+ )))
+ (if (cdr useds)
+ (progn
+ (nail-unused (cdr useds))
+ (handle-used (incf rev-pos)))
+ (handle-used (setf rev-pos 0))))))
+ (trc nil "cd-useds length" (length (cd-useds c)) c)
+ (nail-unused (cd-useds c))
+ (setf (cd-useds c) (delete nil (cd-useds c)))
+ (trc nil "useds of" c :now (mapcar 'qci (cd-useds c)))))))
+
+(defun c-caller-path-exists-p (from-used to-caller)
+ (count-it :caller-path-exists-p)
+ (or (find to-caller (c-callers from-used))
+ (find-if (lambda (from-used-caller)
+ (c-caller-path-exists-p from-used-caller to-caller))
+ (c-callers from-used))))
+
+; ---------------------------------------------
+
+(defun cd-usage-clear-all (c)
+ (setf (cd-usage c) (blank-usage-mask))
+ #+wowo (loop with mask = (cd-usage c)
+ for n fixnum below (array-dimension mask 0)
+ do (setf (sbit mask n) 0)
+ finally (return mask))
+ )
+
+
+;--- unlink from used ----------------------
+
+(defmethod c-unlink-from-used ((caller c-dependent))
+ (dolist (used (cd-useds caller))
+ (trc nil "unlinking from used" caller used)
+ (c-unlink-caller used caller))
+ ;; shouldn't be necessary (setf (cd-useds caller) nil)
+ )
+
+(defmethod c-unlink-from-used (other)
+ (declare (ignore other)))
+
+;----------------------------------------------------------
+
+(defun c-unlink-caller (used caller)
+ (trc nil "(1) caller unlinking from (2) used" caller used)
+ (caller-drop used caller)
+ (c-unlink-used caller used))
+
+(defun c-unlink-used (caller used)
+ (setf (cd-useds caller) (remove used (cd-useds caller))))
+
+;----------------- link debugging ---------------------
+
+(defun dump-callers (c &optional (depth 0))
+ (format t "~&~v,4t~s" depth c)
+ (dolist (caller (c-callers c))
+ (dump-callers caller (+ 1 depth))))
+
+(defun dump-useds (c &optional (depth 0))
+ ;(c.trc "dump-useds> entry " c (+ 1 depth))
+ (when (zerop depth)
+ (format t "x~&"))
+ (format t "~&|usd> ~v,8t~s" depth c)
+ (when (typep c 'c-ruled)
+ ;(c.trc "its ruled" c)
+ (dolist (used (cd-useds c))
+ (dump-useds used (+ 1 depth)))))
Added: dependencies/trunk/cells/load.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/load.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,7 @@
+(require 'asdf)
+(push "/home/alessio/libs/lisp/cells/" asdf:*central-registry*)
+(push "/home/alessio/libs/lisp/cells/utils-kt/" asdf:*central-registry*)
+(asdf:oos 'asdf:load-op :cells)
+
+(push "/home/alessio/libs/lisp/cells/cells-test/" asdf:*central-registry*)
+(asdf:oos 'asdf:load-op :cells-test)
Added: dependencies/trunk/cells/md-slot-value.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/md-slot-value.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,407 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+(defparameter *ide-app-hard-to-kill* t)
+
+(defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name)))
+ (when (and (not *not-to-be*) (mdead self))
+ ;#-its-alive!
+ (unless *stop*
+ (trc nil "md-slot-value passed dead self:" self :asked4slot slot-name :cell c)
+ ;#-sbcl (inspect self)
+ ;(setf *stop* t)
+ ;(break "md-slot-value sees dead ~a" self)
+ )
+ (return-from md-slot-value (slot-value self slot-name))) ;; we can dream
+ (tagbody
+ retry
+ (when *stop*
+ (if *ide-app-hard-to-kill*
+ (progn
+ (princ #\.)
+ (princ "stopped")
+ (return-from md-slot-value))
+ (restart-case
+ (error "Cells is stopped due to a prior error.")
+ (continue ()
+ :report "Return a slot value of nil."
+ (return-from md-slot-value nil))
+ (reset-cells ()
+ :report "Reset cells and retry getting the slot value."
+ (cells-reset)
+ (go retry))))))
+
+ ;; (count-it :md-slot-value slot-name)
+ (if c
+ (cell-read c)
+ (values (slot-value self slot-name) nil)))
+
+(defun cell-read (c)
+ (assert (typep c 'cell))
+ (prog1
+ (with-integrity ()
+ (ensure-value-is-current c :c-read nil))
+ (when *depender*
+ (record-caller c))))
+
+(defun chk (s &optional (key 'anon))
+ (when (mdead s)
+ (break "model ~a is dead at ~a" s key)))
+
+(defvar *trc-ensure* nil)
+
+(defun qci (c)
+ (when c
+ (cons (md-name (c-model c)) (c-slot-name c))))
+
+
+(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
+ ; 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 "evic entry" (qci c))
+ (wtrcx (:on? nil) ("evic>" (qci c) debug-id (qci ensurer))
+ ;(count-it! :ensure.value-is-current )
+ #+chill
+ (when ensurer ; (trcp c)
+ (count-it! :ensure.value-is-current (c-slot-name c) (md-name (c-model c))(c-slot-name ensurer) (md-name (c-model ensurer))))
+ #+chill
+ (when (and *c-debug* (trcp c)
+ (> *data-pulse-id* 650))
+ (bgo ens-high))
+
+ (trc nil ; c ;; (and *c-debug* (> *data-pulse-id* 495)(trcp c))
+ "ensure.value-is-current > entry1" debug-id (qci c) :st (c-state c) :vst (c-value-state c)
+ :my/the-pulse (c-pulse c) *data-pulse-id*
+ :current (c-currentp c) :valid (c-validp c))
+
+ #+nahhh
+ (when ensurer
+ (trc (and *c-debug* (> *data-pulse-id* 495)(trcp c))
+ "ensure.value-is-current > entry2"
+ :ensurer (qci ensurer)))
+
+ (when *not-to-be*
+ (when (c-unboundp c)
+ (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c)))
+ (return-from ensure-value-is-current
+ (when (c-validp c) ;; probably accomplishes nothing
+ (c-value c))))
+
+ (when (and (not (symbolp (c-model c))) ;; damn, just here because of playing around with global vars and cells
+ (eq :eternal-rest (md-state (c-model c))))
+ (break "model ~a of cell ~a is dead" (c-model c) c))
+
+ (cond
+ ((c-currentp c)
+ (count-it! :ensvc-is-indeed-currentp)
+ (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)
+ (c-validp c) ;; a c?n (ruled-then-input) cell will not be valid at first
+ (not (and (typep c 'c-dependent)
+ (eq (cd-optimize c) :when-value-t)
+ (null (c-value c)))))
+ (trc nil "evic: cool: inputp" (qci c)))
+
+ ((or (bwhen (nv (not (c-validp c)))
+ (count-it! :ens-val-not-valid)
+ (trc nil "not c-validp, gonna run regardless!!!!!!" c)
+ nv)
+ ;;
+ ;; new for 2006-09-21: a cell ended up checking slots of a dead instance, which would have been
+ ;; refreshed when checked, but was going to be checked last because it was the first used, useds
+ ;; being simply pushed onto a list as they come up. We may need fancier handling of dead instance/cells
+ ;; still being encountered by consulting the prior useds list, but checking now in same order as
+ ;; accessed seems Deeply Correct (and fixed the immediate problem nicely, always a Good Sign).
+ ;;
+ (labels ((check-reversed (useds)
+ (when useds
+ (or (check-reversed (cdr useds))
+ (let ((used (car useds)))
+ (ensure-value-is-current used :nested c)
+ #+slow (trc nil "comparing pulses (ensurer, used, used-changed): " c debug-id used (c-pulse-last-changed used))
+ (when (> (c-pulse-last-changed used)(c-pulse c))
+ (count-it! :ens-val-someused-newer)
+ (trc nil "used changed and newer !!!!######!!!!!! used" (qci used) :oldpulse (c-pulse 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-state c) (c-validp c) (qci c) :vstate (c-value-state c)
+ :stamped (c-pulse c) :current-pulse *data-pulse-id*)
+ (calculate-and-set c :evic ensurer)
+ (trc nil "kicked off calc-set of!!!!" (c-state c) (c-validp c) (qci c) :vstate (c-value-state c)
+ :stamped (c-pulse c) :current-pulse *data-pulse-id*))
+
+ ((mdead (c-value c))
+ (trc nil "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 :evic-mdead ensurer)))
+ (trc nil "ensure.value-is-current> GOT new value ~a to replace dead!!" new-v)
+ new-v))
+
+ (t (trc nil "ensure.current decided current, updating pulse" (c-slot-name c) debug-id)
+ (c-pulse-update c :valid-uninfluenced)))
+
+ (when (c-unboundp c)
+ (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c)))
+
+ (bwhen (v (c-value c))
+ (if (mdead v)
+ (progn
+ #-its-alive!
+ (progn
+ (format t "~&on pulse ~a ensure.value still got and still not returning ~a dead value ~a" *data-pulse-id* c v)
+ (inspect v))
+ nil)
+ v))))
+
+
+(defun calculate-and-set (c dbgid dbgdata)
+ (declare (ignorable dbgid dbgdata)) ;; just there for inspection of the stack during debugging
+ (flet ((body ()
+ (when (c-stopped)
+ (princ #\.)
+ (return-from calculate-and-set))
+
+ #-its-alive!
+ (bwhen (x (find c *call-stack*)) ;; circularity
+ (unless nil ;; *stop*
+ (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 'asker-midst-askers :cell c))
+
+ (multiple-value-bind (raw-value propagation-code)
+ (calculate-and-link c)
+
+ (when (and *c-debug* (typep raw-value 'cell))
+ (c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))"
+ c raw-value))
+
+ (unless (c-optimized-away-p c)
+ ; this check for optimized-away-p arose because a rule using without-c-dependency
+ ; can be re-entered unnoticed since that clears *call-stack*. If re-entered, a subsequent
+ ; re-exit will be of an optimized away cell, which we need not sv-assume on... a better
+ ; fix might be a less cutesy way of doing without-c-dependency, and I think anyway
+ ; it would be good to lose the re-entrance.
+ (md-slot-value-assume c raw-value propagation-code)))))
+ (if (trcp c) ;; *dbg*
+ (wtrc (0 100 "calcnset" c) (body))
+ (body))))
+
+(defun calculate-and-link (c)
+ (let ((*call-stack* (cons c *call-stack*))
+ (*depender* c)
+ (*defer-changes* t))
+ (assert (typep c 'c-ruled))
+ (trc nil "calculate-and-link" c)
+ (cd-usage-clear-all c)
+ (multiple-value-prog1
+ (funcall (cr-rule c) c)
+ (c-unlink-unused c))))
+
+
+;-------------------------------------------------------------
+
+(defun md-slot-makunbound (self slot-name
+ &aux (c (md-slot-cell self slot-name)))
+ (unless c
+ (c-break ":md-slot-makunbound > cellular slot ~a of ~a cannot be unbound unless initialized as inputp"
+ slot-name self))
+
+ (when (c-unboundp c)
+ (return-from md-slot-makunbound nil))
+
+ (when *within-integrity* ;; 2006-02 oops, bad name
+ (c-break "md-slot-makunbound of ~a must be deffered by wrapping code in with-integrity" c))
+
+ ;
+ ; Big change here for Cells III: before, only the propagation was deferred. Man that seems
+ ; wrong. So now the full makunbound processing gets deferred. Less controversially,
+ ; by contrast the without-c-dependency wrapped everything, and while that is harmless,
+ ; it is also unnecessary and could confuse people trying to follow the logic.
+ ;
+ (let ((causation *causation*))
+ (with-integrity (:change c)
+ (let ((*causation* causation))
+ ; --- cell & slot maintenance ---
+ (let ((prior-value (c-value c)))
+ (setf (c-value-state c) :unbound
+ (c-value c) nil
+ (c-state c) :awake)
+ (bd-slot-makunbound self slot-name)
+ ;
+ ; --- data flow propagation -----------
+ ;
+ (without-c-dependency
+ (c-propagate c prior-value t)))))))
+
+;;; --- setf md.slot.value --------------------------------------------------------
+;;;
+
+(defun (setf md-slot-value) (new-value self slot-name
+ &aux (c (md-slot-cell self slot-name)))
+ #+shhh (when *within-integrity*
+ (trc "mdsetf>" self (type-of self) slot-name :new new-value))
+ (when *c-debug*
+ (c-setting-debug self slot-name c new-value))
+
+ (unless c
+ (c-break "cellular slot ~a of ~a cannot be SETFed because it is not
+mediated by a Cell with :inputp t. To achieve this, the initial value ~s -- whether
+supplied as an :initform, :default-initarg, or at make-instance time via
+an :initarg -- should be wrapped in either macro C-IN or C-INPUT.
+In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
+ slot-name self (slot-value self slot-name)))
+
+ (cond
+ ((find (c-lazy c) '(:once-asked :always t))
+ (md-slot-value-assume c new-value nil))
+
+ (*defer-changes*
+ (c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c))
+
+ (t
+ (with-integrity (:change slot-name)
+ (md-slot-value-assume c new-value nil))))
+
+ ;; new-value
+ ;; above line commented out 2006-05-01. It seems to me we want the value assumed by the slot
+ ;; not the value setf'ed (on rare occasions they diverge, or at least used to for delta slots)
+ ;; anyway, if they no longer diverge the question of which to return is moot
+ )
+
+(defun md-slot-value-assume (c raw-value propagation-code)
+ (assert c)
+ (trc nil "md-slot-value-assume entry" (qci c)(c-state c))
+ (without-c-dependency
+ (let ((prior-state (c-value-state c))
+ (prior-value (c-value c))
+ (absorbed-value (c-absorb-value c raw-value)))
+
+ (c-pulse-update c :slotv-assume)
+
+ ; --- head off unchanged; this got moved earlier on 2006-06-10 ---
+ (when (and (not (eq propagation-code :propagate))
+ (find prior-state '(:valid :uncurrent))
+ (c-no-news c absorbed-value prior-value))
+ (setf (c-value-state c) :valid) ;; new for 2008-07-15
+ (trc nil "(setf md-slot-value) > early no news" propagation-code prior-state prior-value absorbed-value)
+ (count-it :nonews)
+ (return-from md-slot-value-assume absorbed-value))
+
+ ; --- slot maintenance ---
+
+ (unless (c-synaptic c)
+ (md-slot-value-store (c-model c) (c-slot-name c) absorbed-value))
+
+ ; --- cell maintenance ---
+ (setf
+ (c-value c) absorbed-value
+ (c-value-state c) :valid
+ (c-state c) :awake)
+
+ (case (and (typep c 'c-dependent)
+ (cd-optimize c))
+ ((t) (c-optimize-away?! c)) ;;; put optimize test here to avoid needless linking
+ (:when-value-t (when (c-value c)
+ (c-unlink-from-used c))))
+
+ ; --- data flow propagation -----------
+ (unless (eq propagation-code :no-propagate)
+ (trc nil "md-slot-value-assume flagging as changed: prior state, value:" prior-state prior-value )
+ (c-propagate c prior-value (cache-state-bound-p prior-state))) ;; until 06-02-13 was (not (eq prior-state :unbound))
+ (trc nil "exiting md-slot-val-assume" (c-state c) (c-value-state c))
+ absorbed-value)))
+
+(defun cache-bound-p (c)
+ (cache-state-bound-p (c-value-state c)))
+
+(defun cache-state-bound-p (value-state)
+ (or (eq value-state :valid)
+ (eq value-state :uncurrent)))
+
+;---------- optimizing away cells whose dependents all turn out to be constant ----------------
+;
+
+(defun flushed? (c)
+ (rassoc c (cells-flushed (c-model c))))
+
+(defun c-optimize-away?! (c)
+ #+shhh (trc nil "c-optimize-away?! entry" (c-state c) c)
+ (when (and (typep c 'c-dependent)
+ (null (cd-useds c))
+ (cd-optimize c)
+ (not (c-optimized-away-p c)) ;; c-streams (FNYI) may come this way repeatedly even if optimized away
+ (c-validp c) ;; /// when would this not be the case? and who cares?
+ (not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around)
+ (not (c-inputp c)) ;; yes, dependent cells can be inputp
+ )
+ ;; (when (trcp c) (break "go optimizing ~a" c))
+
+ (when (trcp c)
+ (trc "optimizing away" c (c-state c) (rassoc c (cells (c-model c)))(rassoc c (cells-flushed (c-model c))))
+ )
+
+ (count-it :c-optimized)
+
+ (setf (c-state c) :optimized-away)
+
+ (let ((entry (rassoc c (cells (c-model c)))))
+ (unless entry
+ (describe c)
+ (bwhen (fe (rassoc c (cells-flushed (c-model c))))
+ (trc "got in flushed thoi!" fe)))
+ (c-assert entry)
+ ;(trc (eq (c-slot-name c) 'cgtk::id) "c-optimize-away?! moving cell to flushed list" c)
+ (setf (cells (c-model c)) (delete entry (cells (c-model c))))
+ #-its-alive! (push entry (cells-flushed (c-model c)))
+ )
+
+ (dolist (caller (c-callers c) )
+ ;
+ ; 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)))
+ ;;; (trc "nested opti" c caller)
+ (c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...)
+ )))
+
+
Added: dependencies/trunk/cells/md-utilities.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/md-utilities.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,245 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+(defun md-awake (self) (eql :awake (md-state self)))
+
+(defun fm-grandparent (md)
+ (fm-parent (fm-parent md)))
+
+
+(defmethod md-release (other)
+ (declare (ignorable other)))
+
+(export! mdead)
+;___________________ birth / death__________________________________
+
+(defgeneric mdead (self)
+ (:method ((self model-object))
+ (unless *not-to-be* ;; weird
+ (eq :eternal-rest (md-state self))))
+
+ (:method (self)
+ (declare (ignore self))
+ nil))
+
+
+
+(defgeneric not-to-be (self)
+ (:method (other)
+ (declare (ignore other)))
+ (:method ((self cons))
+ (not-to-be (car self))
+ (not-to-be (cdr self)))
+ (: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))
+ (setf (md-census-count self) -1)
+ (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))))
+
+ (:method :around ((self model-object))
+ (declare (ignorable self))
+ (let ((*not-to-be* t)
+ (dbg nil))
+
+ (flet ((gok ()
+ (if (eq (md-state self) :eternal-rest)
+ (trc nil "n2be already dead" self)
+ (progn
+ (call-next-method)
+ (setf (fm-parent self) nil
+ (md-state self) :eternal-rest)
+;;; (bif (a (assoc (type-of self) *awake-ct*))
+;;; (decf (cdr a))
+;;; (break "no awake for" (type-of self) *awake-ct*))
+;;; (setf *awake* (delete self *awake*))
+ (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." c self))) ;; 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)
+ (trc nil "quiescing" c)
+ (c-assert (not (find c *call-stack*)))
+ (c-quiesce c)))
+ (when (register? self)
+ (fm-check-out self)))
+
+(defun c-quiesce (c)
+ (typecase c
+ (cell
+ (trc nil "c-quiesce unlinking" c)
+ (c-unlink-from-used c)
+ (dolist (caller (c-callers c))
+ (setf (c-value-state caller) :uncurrent)
+ (trc nil "c-quiesce totlalaly unlinking caller and making uncurrent" .dpid :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)
+ `(make-instance ,class
+ , at initargs
+ :fm-parent (progn (assert self) self)))
+
+(defvar *c-d-d*)
+(defvar *max-d-d*)
+
+(defparameter *model-pop* nil)
+
+(export! md-census-start md-census-report md-census-count)
+
+(defun md-census-start ()
+ (setf *model-pop* (make-hash-table :test 'eq)))
+
+(defun (setf md-census-count) (delta self)
+ (when *model-pop*
+ (incf (gethash (type-of self) *model-pop* 0) delta)))
+
+(defun md-census-report ()
+ (when *model-pop*
+ (loop for (ct . type)
+ in (sort (let (raw)
+ (maphash (lambda (k v)
+ (push (cons v k) raw))
+ *model-pop*)
+ raw) '< :key 'car)
+ unless (zerop ct)
+ do (trc "pop" ct type))))
+
+#+test
+(md-census-report)
+
+#+test
+(md-census-count)
+
+(defun md-census-count (&optional type)
+ (when *model-pop*
+ (if type
+ (gethash type *model-pop* 0)
+ (loop for v being the hash-values of *model-pop*
+ summing v))))
+
+
+(defun count-model (self &key count-cells &aux (ccc 0))
+
+ (setf *c-d-d* (make-hash-table :test 'eq) *max-d-d* 0)
+ (let ((*counted* (make-hash-table :test 'eq :size 5000)))
+ (with-metrics (t nil "cells statistics for" self)
+ (labels ((cc (self from)
+ (unless (gethash self *counted*)
+ (setf (gethash self *counted*) t)
+ (typecase self
+ (cons (cc (car self) from)
+ (cc (cdr self) from))
+ #+nahhhh (mathx::box (count-it! :mathx-box-struct)
+ (cc (mathx::bx-mx self) from))
+ (model
+ (when (zerop (mod (incf ccc) 100))
+ (trc "cc" (md-name self) (type-of self)))
+ (count-it! :thing)
+ (count-it! :thing (type-of self))
+ #+nahhhh (when (typep self 'mathx::problem)
+ (count-it! :thing-from (type-of self) (type-of from)))
+ (when count-cells
+ (loop for (nil . c) in (cells self)
+ do (count-it! :live-cell)
+ ;(count-it! :live-cell id)
+ (when (c-lazy c)
+ (count-it! :lazy)
+ (count-it! :lazy (c-value-state c)))
+ (typecase c
+ (c-dependent
+ (count-it! :dependent-cell)
+ #+chill (loop repeat (length (c-useds c))
+ do (count-it! :cell-useds)
+ (count-it! :dep-depth (c-depend-depth c))))
+ (otherwise (if (c-inputp c)
+ (progn
+ (count-it! :c-input-altogether)
+ ;(count-it! :c-input id)
+ )
+ (count-it! :c-unknown))))
+
+ (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 self)))
+ #+nahhh
+ (progn
+ (when (typep self 'mathx::mx-optr)
+ (cc (mathx::opnds self) from))
+ (when (typep self 'mathx::math-expression)
+ (count-it! :math-expression))))
+ (otherwise
+ (count-it (type-of self)))))))
+ (cc self nil)))))
+
+(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
Added: dependencies/trunk/cells/model-object.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/model-object.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,331 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+;;; --- model-object ----------------------
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(md-name fm-parent .parent )))
+
+(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)
+ (.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)))
+
+(defmethod register? ((self model-object)))
+
+(defmethod md-state ((self symbol))
+ :alive)
+;;; --- md obj initialization ------------------
+
+(defmethod shared-initialize :after ((self model-object) slotnames
+ &rest initargs &key fm-parent)
+ (declare (ignorable initargs slotnames fm-parent))
+ (setf (md-census-count self) 1) ;; bad idea if we get into reinitializing
+ ;
+ ; for convenience and transparency of mechanism we allow client code
+ ; to intialize a slot to a cell, but we want the slot to hold the functional
+ ; value, partly for ease of inspection, partly for performance, mostly
+ ; because sometimes we are a slave to other libraries, such as a persistence
+ ; library that does interesting things automatically based on the slot value.
+ ;
+ ; here we shuttle cells out of the slots and into a per-instance dictionary of cells,
+ ; as well as tell the cells what slot and instance they are mediating.
+ ;
+
+ (when (slot-boundp self '.md-state)
+ (loop for esd in (class-slots (class-of self))
+ for sn = (slot-definition-name esd)
+ for sv = (when (slot-boundp self sn)
+ (slot-value self sn))
+ ;; do (print (list (type-of self) sn sv (typep sv 'cell)))
+ when (typep sv 'cell)
+ do (if (md-slot-cell-type (type-of self) sn)
+ (md-install-cell self sn sv)
+ (when *c-debug*
+ (break "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv sn (type-of self)))))
+ ;
+ ; queue up for awakening
+ ;
+ (if (awaken-on-init-p self)
+ (md-awaken self)
+ (with-integrity (:awaken self)
+ (md-awaken self)))
+ ))
+
+(defun md-install-cell (self slot-name c &aux (c-isa-cell (typep c 'cell)))
+ ;
+ ; iff cell, init and move into dictionary
+ ;
+ (when c-isa-cell
+ (count-it :md-install-cell)
+ (setf
+ (c-model c) self
+ (c-slot-name c) slot-name
+ (md-slot-cell self slot-name) c))
+ ;
+ ; now have the slot really be the slot
+ ;
+ (if c-isa-cell
+ (if (c-unboundp c)
+ (bd-slot-makunbound self slot-name)
+ (if self
+ (setf (slot-value self slot-name)
+ (when (c-inputp c) (c-value c)))
+ (setf (symbol-value slot-name)
+ (when (c-inputp c) (c-value c)))))
+ ;; note that in this else branch "c" is a misnomer since
+ ;; the value is not actually a cell
+ (if self
+ (setf (slot-value self slot-name) c)
+ (setf (symbol-value slot-name) c))))
+
+
+;;; --- awaken --------
+;
+; -- do initial evaluation of all ruled slots
+; -- call observers of all slots
+
+
+
+(export! md-awake-ct md-awake-ct-ct)
+(defun md-awake-ct ()
+ *awake-ct*)
+
+(defun md-awake-ct-ct ()
+ (reduce '+ *awake-ct* :key 'cdr))
+
+
+(defmethod md-awaken :around ((self model-object))
+ (when (eql :nascent (md-state self))
+ #+nahh (bif (a (assoc (type-of self) *awake-ct*))
+ (incf (cdr a))
+ (push (cons (type-of self) 1) *awake-ct*))
+ ;(trc "awake" (type-of self))
+ #+chya (push self *awake*)
+ (call-next-method))
+ self)
+
+#+test
+(md-slot-cell-type 'cgtk::label 'cgtk::container)
+
+(defmethod md-awaken ((self model-object))
+ ;
+ ; --- debug stuff
+ ;
+ (when *stop*
+ (princ #\.)
+ (return-from md-awaken))
+ (trc nil "md-awaken entry" self (md-state self))
+ (c-assert (eql :nascent (md-state self)))
+ (count-it :md-awaken)
+ ;(count-it 'mdawaken (type-of self))
+
+ ; ---
+
+ (setf (md-state self) :awakening)
+
+ (dolist (esd (class-slots (class-of self)))
+ (bwhen (sct (md-slot-cell-type (type-of self) (slot-definition-name esd)))
+ (let* ((slot-name (slot-definition-name esd))
+ (c (md-slot-cell self slot-name)))
+ (when *c-debug*
+ (bwhen (sv (and (slot-boundp self slot-name)
+ (slot-value self slot-name)))
+ (when (typep sv 'cell)
+ (c-break "md-awaken ~a found cell ~a in slot ~a" self sv esd))))
+
+ (cond
+ ((not c)
+ ;; all slots must hit any change handlers as instances come into existence to get
+ ;; models fully connected to the outside world they are controlling. that
+ ;; happens in awaken-cell for slots in fact mediated by cells, but as an
+ ;; optimization we allow raw literal values to be specified for a slot, in
+ ;; which case heroic measures are needed to get the slot to the change handler
+ ;;
+ ;; 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.
+ ;;
+ ;; 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
+
+ (let ((flushed (md-slot-cell-flushed self slot-name)))
+ (when (or (null flushed) ;; constant, ie, never any cell provided for this slot
+ (> *data-pulse-id* (c-pulse-observed flushed))) ;; unfrickinlikely
+ (when flushed
+ (setf (c-pulse-observed flushed) *data-pulse-id*)) ;; probably unnecessary
+ (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil flushed))))
+
+ ((find (c-lazy c) '(:until-asked :always t))
+ (trc nil "md-awaken deferring c-awaken since lazy"
+ self esd))
+
+ ((eq :nascent (c-state c))
+ (c-assert (c-model c) () "c-awaken sees uninstalled cell" c)
+ (c-assert (eq :nascent (c-state c)))
+ (trc nil "c-awaken > awakening" c)
+ (count-it :c-awaken)
+
+ (setf (c-state c) :awake)
+ (awaken-cell c))))))
+
+ (setf (md-state self) :awake)
+ self)
+
+;;; --- utilities, accessors, etc --------------------------------------
+
+(defmethod c-slot-value ((self model-object) slot)
+ (slot-value self slot))
+
+(defmethod md-slot-cell (self slot-name)
+ (if self
+ (cdr (assoc slot-name (cells self)))
+ (get slot-name 'cell)))
+
+(defmethod md-slot-cell-flushed (self slot-name)
+ (if self
+ (cdr (assoc slot-name (cells-flushed self)))
+ (get slot-name 'cell)))
+
+#+test
+(get 'cgtk::label :cell-types)
+
+(defun md-slot-cell-type (class-name slot-name)
+ (assert class-name)
+ (if (eq class-name 'null)
+ (get slot-name :cell-type)
+ (bif (entry (assoc slot-name (get class-name :cell-types)))
+ (cdr entry)
+ (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))))))))
+
+(defun (setf md-slot-cell-type) (new-type class-name slot-name)
+ (assert class-name)
+ (if (eq class-name 'null) ;; not def-c-variable
+ (setf (get slot-name :cell-type) new-type)
+ (let ((entry (assoc slot-name (get class-name :cell-types))))
+ (if entry
+ (prog1
+ (setf (cdr entry) new-type)
+ (loop for c in (class-direct-subclasses (find-class class-name))
+ 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)))))))
+
+#+test
+(md-slot-owning? 'm-index '.value)
+
+(defun md-slot-owning? (class-name slot-name)
+ (assert class-name)
+ (if (eq class-name 'null)
+ (get slot-name :owning) ;; might be wrong -- support for specials is unfinished w.i.p.
+ (bif (entry (assoc slot-name (get class-name :direct-ownings)))
+ (cdr entry)
+ (bif (entry (assoc slot-name (get class-name :indirect-ownings)))
+ (cdr entry)
+ (cdar
+ (push (cons slot-name
+ (cdr (loop for super in (cdr (class-precedence-list (find-class class-name)))
+ thereis (assoc slot-name (get (c-class-name super) :direct-ownings)))))
+ (get class-name :indirect-ownings)))))))
+
+(defun (setf md-slot-owning-direct?) (value class-name slot-name)
+ (assert class-name)
+ (if (eq class-name 'null) ;; global variables
+ (setf (get slot-name :owning) value)
+ (progn
+ (bif (entry (assoc slot-name (get class-name :direct-ownings)))
+ (setf (cdr entry) value)
+ (push (cons slot-name value) (get class-name :direct-ownings)))
+ ; -- propagate to derivatives ...
+ (labels ((clear-subclass-ownings (c)
+ (loop for sub-c in (class-direct-subclasses c)
+ for sub-c-name = (c-class-name sub-c)
+ do (setf (get sub-c-name :indirect-ownings)
+ (delete slot-name (get sub-c-name :indirect-ownings) :key 'car)) ;; forces redecide
+ (setf (get sub-c-name :model-ownings) nil) ;; too much forcing full recalc like this?
+ (clear-subclass-ownings sub-c))))
+ (clear-subclass-ownings (find-class class-name))))))
+
+(defun md-owning-slots (self &aux (st (type-of self)))
+ (or (get st :model-ownings)
+ (setf (get st :model-ownings)
+ (loop for s in (class-slots (class-of self))
+ for sn = (slot-definition-name s)
+ when (and (md-slot-cell-type st sn)
+ (md-slot-owning? st sn))
+ collect sn))))
+
+#+test
+(md-slot-owning? 'cells::family '.kids)
+
+(defun md-slot-value-store (self slot-name new-value)
+ (trc nil "md-slot-value-store" self slot-name new-value)
+ (if self
+ (setf (slot-value self slot-name) new-value)
+ (setf (symbol-value slot-name) new-value)))
+
+;----------------- navigation: slot <> initarg <> esd <> cell -----------------
+
+#+cmu
+(defmethod c-class-name ((class pcl::standard-class))
+ (pcl::class-name class))
+
+(defmethod c-class-name (other) (declare (ignore other)) nil)
+
+;; why not #-cmu?
+(defmethod c-class-name ((class standard-class))
+ (class-name class))
+
+(defmethod cell-when (other) (declare (ignorable other)) nil)
+
+(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
+ (progn
+ (trc nil "second cell same slot:" slot-name :old entry :new new-cell)
+ (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter
+ (declare (ignorable old))
+ (c-assert (null (c-callers old)))
+ (when (typep entry 'c-dependent)
+ (c-assert (null (cd-useds old))))
+ (trc nil "replacing in model .cells" old new-cell self)
+ (rplacd entry new-cell)))
+ (progn
+ (trc nil "adding to model .cells" new-cell self)
+ (push (cons slot-name new-cell)
+ (cells self))))
+ (setf (get slot-name 'cell) new-cell)))
+
+(defun md-map-cells (self type celldo)
+ (map type (lambda (cell-entry)
+ (bwhen (cell (cdr cell-entry))
+ (unless (listp cell)
+ (funcall celldo cell))))
+ (cells self)))
Added: dependencies/trunk/cells/propagate.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/propagate.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,291 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+;----------------- change detection ---------------------------------
+
+(defun c-no-news (c new-value old-value)
+ ;;; (trc nil "c-no-news > checking news between" newvalue oldvalue)
+ (bif (test (c-unchanged-test (c-model c) (c-slot-name c)))
+ (funcall test new-value old-value)
+ (eql new-value old-value)))
+
+(defmacro def-c-unchanged-test ((class slotname) &body test)
+ `(defmethod c-unchanged-test ((self ,class) (slotname (eql ',slotname)))
+ , at test))
+
+(defmethod c-unchanged-test (self slotname)
+ (declare (ignore self slotname))
+ nil)
+
+; --- data pulse (change ID) management -------------------------------------
+
+(defparameter *one-pulse?* nil)
+
+(defun data-pulse-next (pulse-info)
+ (declare (ignorable pulse-info))
+ (unless *one-pulse?*
+ ;(trc "dp-next> " (1+ *data-pulse-id*) pulse-info)
+ #+chill (when *c-debug*
+ (push (list :data-pulse-next pulse-info) *istack*))
+ (incf *data-pulse-id*)))
+
+(defun c-currentp (c)
+ (eql (c-pulse c) *data-pulse-id*))
+
+(defun c-pulse-update (c key)
+ (declare (ignorable key))
+ (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*))
+
+;--------------- propagate ----------------------------
+; n.b. the cell argument may have been optimized away,
+; though it is still receiving final processing here.
+
+(defparameter *per-cell-handler* nil)
+
+(defun c-propagate (c prior-value prior-value-supplied)
+ (when *one-pulse?*
+ (when *per-cell-handler*
+ (funcall *per-cell-handler* c prior-value prior-value-supplied)
+ (return-from c-propagate)))
+
+ (count-it :cpropagate)
+ (setf (c-pulse-last-changed c) *data-pulse-id*)
+
+ (when prior-value
+ (assert prior-value-supplied () "How can prior-value-supplied be nil if prior-value is not?!! ~a" c))
+ (let (*depender* *call-stack* ;; I think both need clearing, cuz we are neither depending nor calling when we prop to callers
+ (*c-prop-depth* (1+ *c-prop-depth*))
+ (*defer-changes* t))
+ (trc nil "c.propagate clearing *depender*" c)
+
+ ;------ debug stuff ---------
+ ;
+ (when *stop*
+ (princ #\.)(princ #\!)
+ (return-from c-propagate))
+ (trc nil "c.propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)))
+ #+slow (trc nil "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))
+ (when (> *c-prop-depth* 300)
+ (c-break "c.propagate looping ~c" c)))
+
+ ; --- manifest new value as needed ---
+ ;
+ ; 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
+ ; pb to decide its own pt), the doomed kid will still have a parent but not be in its kids slot
+ ; when it goes looking for a sibling relative to its position.
+ ;
+ (when (and prior-value-supplied
+ prior-value
+ (md-slot-owning? (type-of (c-model c)) (c-slot-name c)))
+ (trc nil "c.propagate> contemplating lost" (qci c))
+ (flet ((listify (x) (if (listp x) x (list x))))
+ (bif (lost (set-difference (listify prior-value) (listify (c-value c))))
+ (progn
+ (trc nil "prop nailing owned!!!!!!!!!!!" (qci c) :lost (length lost)) ;; :leaving (c-value c))
+ (loop for l in lost
+ when (numberp l)
+ do (break "got num ~a" (list l (type-of (c-model c))(c-slot-name c)
+ (md-slot-owning? (type-of (c-model c)) (c-slot-name c)))))
+ (mapcar 'not-to-be lost))
+ (trc nil "no owned lost!!!!!"))))
+
+ ; propagation to callers jumps back in front of client slot-value-observe handling in cells3
+ ; because model adopting (once done by the kids change handler) can now be done in
+ ; shared-initialize (since one is now forced to supply the parent to make-instance).
+ ;
+ ; we wnat it here to support (eventually) state change rollback. change handlers are
+ ; expected to have side-effects, so we want to propagate fully and be sure no rule
+ ; wants a rollback before starting with the side effects.
+ ;
+ (progn ;; unless (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this
+ (c-propagate-to-callers c))
+
+ (trc nil "c.propagate observing" c)
+
+ ; this next assertion is just to see if we can ever come this way twice. If so, just
+ ; make it a condition on whether to observe
+ (when t ; breaks algebra (> *data-pulse-id* (c-pulse-observed c))
+ (setf (c-pulse-observed c) *data-pulse-id*)
+ (slot-value-observe (c-slot-name c) (c-model c)
+ (c-value c) prior-value prior-value-supplied c))
+
+
+ ;
+ ; with propagation done, ephemerals can be reset. we also do this in c-awaken, so
+ ; let the fn decide if C really is ephemeral. Note that it might be possible to leave
+ ; this out and use the datapulse to identify obsolete ephemerals and clear them
+ ; when read. That would avoid ever making again bug I had in which I had the reset inside slot-value-observe,
+ ; thinking that that always followed propagation to callers. It would also make
+ ; debugging easier in that I could find the last ephemeral value in the inspector.
+ ; would this be bad for persistent CLOS, in which a DB would think there was still a link
+ ; between two records until the value actually got cleared?
+ ;
+ (ephemeral-reset c)))
+
+; --- slot change -----------------------------------------------------------
+
+(defmacro defobserver (slotname &rest args &aux (aroundp (eq :around (first args))))
+ (when aroundp (setf args (cdr args)))
+ (when (find slotname '(value kids))
+ (break "d: did you mean .value or .kids when you coded ~a?" slotname))
+ (destructuring-bind ((&optional (self-arg 'self) (new-varg 'new-value)
+ (oldvarg 'old-value) (oldvargboundp 'old-value-boundp) (cell-arg 'c))
+ &body output-body) args
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (get ',slotname :output-defined) t))
+ ,(if (eql (last1 output-body) :test)
+ (let ((temp1 (gensym))
+ (loc-self (gensym)))
+ `(defmethod slot-value-observe #-(or cormanlisp) ,(if aroundp :around 'progn)
+ ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp ,cell-arg)
+ (let ((,temp1 (bump-output-count ,slotname))
+ (,loc-self ,(if (listp self-arg)
+ (car self-arg)
+ self-arg)))
+ (when (and ,oldvargboundp ,oldvarg)
+ (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg ,cell-arg))
+ (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg ,cell-arg))))
+ `(defmethod slot-value-observe
+ #-(or cormanlisp) ,(if aroundp :around 'progn)
+ ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp ,cell-arg)
+ (declare (ignorable
+ ,@(flet ((arg-name (arg-spec)
+ (etypecase arg-spec
+ (list (car arg-spec))
+ (atom arg-spec))))
+ (list (arg-name self-arg)(arg-name new-varg)
+ (arg-name oldvarg)(arg-name oldvargboundp) (arg-name cell-arg)))))
+ , at output-body)))))
+
+(defmacro bump-output-count (slotname) ;; pure test func
+ `(if (get ',slotname :outputs)
+ (incf (get ',slotname :outputs))
+ (setf (get ',slotname :outputs) 1)))
+
+; --- recalculate dependents ----------------------------------------------------
+
+
+(defmacro cll-outer (val &body body)
+ `(let ((outer-val ,val))
+ , at body))
+
+(defmacro cll-inner (expr)
+ `(,expr outer-val))
+
+(export! cll-outer cll-inner)
+
+(defun c-propagate-to-callers (c)
+ ;
+ ; We must defer propagation to callers because of an edge case in which:
+ ; - X tells A to recalculate
+ ; - A asks B for its current value
+ ; - B must recalculate because it too uses X
+ ; - if B propagates to its callers after recalculating instead of deferring it
+ ; - B might tell H to reclaculate, where H decides this time to use A
+ ; - but A is in the midst of recalculating, and cannot complete until B returns.
+ ; but B is busy eagerly propagating. "This time" is important because it means
+ ; there is no way one can reliably be sure H will not ask for A
+ ;
+ (when (find-if-not (lambda (caller)
+ (and (c-lazy caller) ;; slight optimization
+ (member (c-lazy caller) '(t :always :once-asked))))
+ (c-callers c))
+ (let ((causation (cons c *causation*))) ;; in case deferred
+ #+slow (trc nil "c.propagate-to-callers > queueing notifying callers" (c-callers c))
+ (with-integrity (:tell-dependents c)
+ (assert (null *call-stack*))
+ (assert (null *depender*))
+ ;
+ (if (mdead (c-model c))
+ (trc nil "WHOAA!!!! dead by time :tell-deps dispatched; bailing" c)
+ (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))
+ #+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 (c-callers c))
+ (trc nil "propagating to caller iterates" c :caller caller (c-state caller) (c-lazy caller))
+ (block do-a-caller
+ (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced
+ (member (c-lazy caller) '(t :always :once-asked)))
+ (unless (find c (cd-useds caller))
+ (trc "WHOA!!!! Bailing on Known caller:" caller :does-not-in-its-used c)
+ (return-from do-a-caller))
+ #+slow (trc nil "propagating to caller is used" c :caller caller (c-currentp c))
+ (let ((*trc-ensure* (trcp c)))
+ ;
+ ; we just calculate-and-set at the first level of dependency because
+ ; we do not need to check the next level (as ensure-value-is-current does)
+ ; because we already know /this/ notifying dependency has changed, so yeah,
+ ; any first-level cell /has to/ recalculate. (As for ensuring other dependents
+ ; of the first level guy are current, that happens automatically anyway JIT on
+ ; any read.) This is a minor efficiency enhancement since ensure-value-is-current would
+ ; very quickly decide it has to re-run, but maybe it makes the logic clearer.
+ ;
+ ;(ensure-value-is-current caller :prop-from c) <-- next was this, but see above change reason
+ ;
+ (unless (c-currentp caller) ; happens if I changed when caller used me in current pulse
+ (calculate-and-set caller :propagate c))))))))))))
+
+(defparameter *the-unpropagated* nil)
+
+(defmacro with-one-datapulse ((&key (per-cell nil per-cell?) (finally nil finally?)) &body body)
+ `(call-with-one-datapulse (lambda () , at body)
+ ,@(when per-cell? `(:per-cell (lambda (c prior-value prior-value-boundp)
+ (declare (ignorable c prior-value prior-value-boundp))
+ ,per-cell)))
+ ,@(when finally? `(:finally (lambda (cs) (declare (ignorable cs)) ,finally)))))
+
+(defun call-with-one-datapulse
+ (f &key
+ (per-cell (lambda (c prior-value prior-value?)
+ (unless (find c *the-unpropagated* :key 'car)
+ (pushnew (list c prior-value prior-value?) *the-unpropagated*))))
+ (finally (lambda (cs)
+ (print `(finally sees ,*data-pulse-id* ,cs))
+ ;(trace c-propagate ensure-value-is-current)
+ (loop for (c prior-value prior-value?) in (nreverse cs) do
+ (c-propagate c prior-value prior-value?)))))
+ (assert (not *one-pulse?*))
+ (data-pulse-next :client-prop)
+ (trc "call-with-one-datapulse bumps pulse" *data-pulse-id*)
+ (funcall finally
+ (let ((*one-pulse?* t)
+ (*per-cell-handler* per-cell)
+ (*the-unpropagated* nil))
+ (funcall f)
+ *the-unpropagated*)))
+
Added: dependencies/trunk/cells/slot-utilities.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/slot-utilities.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,97 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+(defun c-setting-debug (self slot-name c new-value)
+ (declare (ignorable new-value))
+ (cond
+ ((null c)
+ (format t "c-setting-debug > constant ~a in ~a may not be altered..init to (c-in nil)"
+ slot-name self)
+
+ (c-break "setting-const-cell")
+ (error "setting-const-cell"))
+ ((c-inputp c))
+ (t
+ (let ((self (c-model c))
+ (slot-name (c-slot-name c)))
+ ;(trc "c-setting-debug sees" c newvalue self slot-name)
+ (when (and c (not (and slot-name self)))
+ ;; cv-test handles errors, so don't set *stop* (c-stop)
+ (c-break "unadopted ~a for self ~a spec ~a" c self slot-name)
+ (error 'c-unadopted :cell c))
+ #+whocares (typecase c
+ (c-dependent
+ ;(trc "setting c-dependent" c newvalue)
+ (format t "c-setting-debug > ruled ~a in ~a may not be setf'ed"
+ (c-slot-name c) self)
+
+ (c-break "setting-ruled-cell")
+ (error "setting-ruled-cell"))
+ )))))
+
+(defun c-absorb-value (c value)
+ (typecase c
+ (c-drifter-absolute (c-value-incf c value 0)) ;; strange but true
+ (c-drifter (c-value-incf c (c-value c) value))
+ (t value)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(c-value-incf)))
+
+(defmethod c-value-incf (c (envaluer c-envaluer) delta)
+ (c-assert (c-model c))
+ (c-value-incf c (funcall (envalue-rule envaluer) c)
+ delta))
+
+(defmethod c-value-incf (c (base number) delta)
+ (declare (ignore c))
+ (if delta
+ (+ base delta)
+ base))
+
+
+;----------------------------------------------------------------------
+
+(defun bd-slot-value (self slot-name)
+ (slot-value self slot-name))
+
+(defun (setf bd-slot-value) (new-value self slot-name)
+ (setf (slot-value self slot-name) new-value))
+
+(defun bd-bound-slot-value (self slot-name caller-id)
+ (declare (ignorable caller-id))
+ (when (bd-slot-boundp self slot-name)
+ (bd-slot-value self slot-name)))
+
+(defun bd-slot-boundp (self slot-name)
+ (slot-boundp self slot-name))
+
+(defun bd-slot-makunbound (self slot-name)
+ (if slot-name ;; not in def-c-variable
+ (slot-makunbound self slot-name)
+ (makunbound self)))
+
+#| sample incf
+(defmethod c-value-incf ((base fpoint) delta)
+ (declare (ignore model))
+ (if delta
+ (fp-add base delta)
+ base))
+|#
Added: dependencies/trunk/cells/synapse-types.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/synapse-types.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,152 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :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 () , at body)))
+
+(defun call-f-sensitivity (synapse-id sensitivity subtypename body-fn)
+ (with-synapse synapse-id (prior-fire-value)
+ (let ((new-value (funcall body-fn)))
+ ;(trc "f-sensitivity fire-p decides new" new-value :from-prior prior-fire-value :sensi sensitivity)
+ (let ((prop-code (if (or (xor prior-fire-value new-value)
+ (eko (nil "sens fire-p decides" new-value prior-fire-value sensitivity)
+ (delta-greater-or-equal
+ (delta-abs (delta-diff new-value prior-fire-value subtypename)
+ subtypename)
+ (delta-abs sensitivity subtypename)
+ subtypename)))
+ :propagate
+ :no-propagate)))
+ (values (if (eq prop-code :propagate)
+ (progn
+ (trc nil "sense prior fire value now" new-value)
+ (setf prior-fire-value new-value))
+ new-value) prop-code)))))
+
+(defmacro f-delta (synapse-id (&key sensitivity (type 'number)) &body body)
+ `(call-f-delta ,synapse-id ,sensitivity ',type (lambda () , at body)))
+
+(defun call-f-delta (synapse-id sensitivity type body-fn)
+ (with-synapse synapse-id (last-relay-basis last-bound-p delta-cum)
+ (let* ((new-basis (funcall body-fn))
+ (threshold sensitivity)
+ (tdelta (delta-diff new-basis
+ (if last-bound-p
+ last-relay-basis
+ (delta-identity new-basis type))
+ type)))
+ (trc nil "tdelta, threshhold" tdelta threshold)
+ (setf delta-cum tdelta)
+ (let ((propagation-code
+ (when threshold
+ (if (delta-exceeds tdelta threshold type)
+ (progn
+ (setf last-bound-p t)
+ (setf last-relay-basis new-basis)
+ :propagate)
+ :no-propagate))))
+ (trc nil "f-delta returns values" delta-cum propagation-code)
+ (values delta-cum propagation-code)))))
+
+(defmacro f-plusp (key &rest body)
+ `(with-synapse ,key (prior-fire-value)
+ (let ((new-basis (progn , at body)))
+ (values new-basis (if (xor prior-fire-value (plusp new-basis))
+ (progn
+ (setf prior-fire-value (plusp new-basis))
+ :propagate)
+ :no-propagate)))))
+
+(defmacro f-zerop (key &rest body)
+ `(with-synapse ,key (prior-fire-value)
+ (let ((new-basis (progn , at body)))
+ (values new-basis (if (xor prior-fire-value (zerop new-basis))
+ (progn
+ (setf prior-fire-value (zerop new-basis))
+ :propagate)
+ :no-propagate)))))
+
+
+
+;;;(defun f-delta-list (&key (test #'true))
+;;; (with-synapse (prior-list)
+;;; :fire-p (lambda (syn new-list)
+;;; (declare (ignorable syn))
+;;; (or (find-if (lambda (new)
+;;; ;--- gaining one? ----
+;;; (and (not (member new prior-list))
+;;; (funcall test new)))
+;;; new-list)
+;;; (find-if (lambda (old)
+;;; ;--- losing one? ----
+;;; (not (member old new-list))) ;; all olds have passed test, so skip test here
+;;; prior-list)))
+;;;
+;;; :fire-value (lambda (syn new-list)
+;;; (declare (ignorable syn))
+;;; ;/// excess consing on long lists
+;;; (setf prior-list (remove-if-not test new-list)))))
+
+;;;(defun f-find-once (finder-fn)
+;;; (mk-synapse (bingo bingobound)
+;;;
+;;; :fire-p (lambda (syn new-list)
+;;; (declare (ignorable syn))
+;;; (unless bingo ;; once found, yer done
+;;; (setf bingobound t
+;;; bingo (find-if finder-fn new-list))))
+;;;
+;;; :fire-value (lambda (syn new-list)
+;;; (declare (ignorable syn))
+;;; (or bingo
+;;; (and (not bingobound) ;; don't bother if fire? already looked
+;;; (find-if finder-fn new-list))))))
+
+;;;(defun fdifferent ()
+;;; (mk-synapse (prior-object)
+;;; :fire-p (lambda (syn new-object)
+;;; (declare (ignorable syn))
+;;; (trc nil "fDiff: prior,new" (not (eql new-object prior-object))
+;;; prior-object new-object)
+;;; (not (eql new-object prior-object)))
+;;;
+;;; :fire-value (lambda (syn new-object)
+;;; (declare (ignorable syn))
+;;; (unless (eql new-object prior-object)
+;;; (setf prior-object new-object)))
+;;; ))
+
+
+;;;(defun f-boolean (&optional (sensitivity 't))
+;;; (f-delta :sensitivity sensitivity :type 'boolean))
+
+
Added: dependencies/trunk/cells/synapse.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/synapse.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,89 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (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)))
+ `(let* ((,syn-id ,synapse-id)
+ (synapse (or (find ,syn-id (cd-useds *depender*) :key 'c-slot-name)
+ (let ((new-syn
+ (let (, at closure-vars)
+ (make-c-dependent
+ :model (c-model *depender*)
+ :slot-name ,syn-id
+ :code ',body
+ :synaptic t
+ :rule (c-lambda , at body)))))
+ (record-caller new-syn)
+ new-syn))))
+ (prog1
+ (multiple-value-bind (v p)
+ (with-integrity ()
+ (ensure-value-is-current synapse :synapse *depender*))
+ (values v p))
+ (record-caller synapse)))))
+
+
+;__________________________________________________________________________________
+;
+
+(defmethod delta-exceeds (bool-delta sensitivity (subtypename (eql 'boolean)))
+ (unless (eql bool-delta :unchanged)
+ (or (eq sensitivity t)
+ (eq sensitivity bool-delta))))
+
+(defmethod delta-diff ((new number) (old number) subtypename)
+ (declare (ignore subtypename))
+ (- new old))
+
+(defmethod delta-identity ((dispatcher number) subtypename)
+ (declare (ignore subtypename))
+ 0)
+
+(defmethod delta-abs ((n number) subtypename)
+ (declare (ignore subtypename))
+ (abs n))
+
+(defmethod delta-exceeds ((d1 number) (d2 number) subtypename)
+ (declare (ignore subtypename))
+ (> d1 d2))
+
+(defmethod delta-greater-or-equal ((d1 number) (d2 number) subtypename)
+ (declare (ignore subtypename))
+ (>= d1 d2))
+
+;_________________________________________________________________________________
+;
+(defmethod delta-diff (new old (subtypename (eql 'boolean)))
+ (if new
+ (if old
+ :unchanged
+ :on)
+ (if old
+ :off
+ :unchanged)))
+
+
+(defmethod delta-identity (dispatcher (subtypename (eql 'boolean)))
+ (declare (ignore dispatcher))
+ :unchanged)
+
Added: dependencies/trunk/cells/test-cc.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/test-cc.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,40 @@
+(in-package :cells)
+
+(defmd tcc ()
+ (tccversion 1)
+ (tcc-a (c-in nil))
+ (tcc-2a (c-in nil)))
+
+(defobserver tcc-a ()
+ (case (^tccversion)
+ (1 (when new-value
+ (with-cc :tcc-a-obs
+ (setf (tcc-2a self) (* 2 new-value))
+ (with-cc :aha!2
+ (assert (eql (tcc-2a self) (* 2 new-value))
+ () "one")
+ (trc "one happy")))
+ (with-cc :aha!
+ (assert (eql (tcc-2a self) (* 2 new-value))
+ () "two"))))
+ (2 (when new-value
+ (with-cc :tcc-a-obs
+ (setf (tcc-2a self) (* 2 new-value))
+ (with-cc :aha!2
+ (assert (eql (tcc-2a self) (* 2 new-value))
+ () "one")
+ (trc "one happy")))))))
+
+
+(defun test-with-cc ()
+ (let ((self (make-instance 'tcc
+ :tccversion 2 ;:tcc-2a
+ )))
+ (trcx cool 42)
+ (setf (tcc-a self) 42)
+ (assert (and (numberp (tcc-2a self))
+ (= (tcc-2a self) 84)))))
+
+#+test
+(test-with-cc)
+
Added: dependencies/trunk/cells/test-cycle.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/test-cycle.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,77 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+
+
+(defmodel m-cyc ()
+ ((m-cyc-a :initform (c-in nil) :initarg :m-cyc-a :accessor m-cyc-a)
+ (m-cyc-b :initform (c-in nil) :initarg :m-cyc-b :accessor m-cyc-b)))
+
+(def-c-output m-cyc-a ()
+ (print `(output m-cyc-a ,self ,new-value ,old-value))
+ (setf (m-cyc-b self) new-value))
+
+(def-c-output m-cyc-b ()
+ (print `(output m-cyc-b ,self ,new-value ,old-value))
+ (setf (m-cyc-a self) new-value))
+
+(defun m-cyc () ;;def-cell-test m-cyc
+ (let ((m (make-be 'm-cyc)))
+ (print `(start ,(m-cyc-a m)))
+ (setf (m-cyc-a m) 42)
+ (assert (= (m-cyc-a m) 42))
+ (assert (= (m-cyc-b m) 42))))
+
+#+(or)
+(m-cyc)
+
+(defmodel m-cyc2 ()
+ ((m-cyc2-a :initform (c-in 0) :initarg :m-cyc2-a :accessor m-cyc2-a)
+ (m-cyc2-b :initform (c? (1+ (^m-cyc2-a)))
+ :initarg :m-cyc2-b :accessor m-cyc2-b)))
+
+(def-c-output m-cyc2-a ()
+ (print `(output m-cyc2-a ,self ,new-value ,old-value))
+ #+(or) (when (< new-value 45)
+ (setf (m-cyc2-b self) (1+ new-value))))
+
+(def-c-output m-cyc2-b ()
+ (print `(output m-cyc2-b ,self ,new-value ,old-value))
+ (when (< new-value 45)
+ (setf (m-cyc2-a self) (1+ new-value))))
+
+(def-cell-test m-cyc2
+ (cell-reset)
+ (let ((m (make-be 'm-cyc2)))
+ (print '(start))
+ (setf (m-cyc2-a m) 42)
+ (describe m)
+ (assert (= (m-cyc2-a m) 44))
+ (assert (= (m-cyc2-b m) 45))
+ ))
+
+#+(or)
+(m-cyc2)
+
+
Added: dependencies/trunk/cells/test-ephemeral.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/test-ephemeral.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,57 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+
+(defmodel m-ephem ()
+ ((m-ephem-a :cell :ephemeral :initform nil :initarg :m-ephem-a :accessor m-ephem-a)
+ (m-test-a :cell nil :initform nil :initarg :m-test-a :accessor m-test-a)
+ (m-ephem-b :cell :ephemeral :initform nil :initarg :m-ephem-b :accessor m-ephem-b)
+ (m-test-b :cell nil :initform nil :initarg :m-test-b :accessor m-test-b)))
+
+(def-c-output m-ephem-a ()
+ (setf (m-test-a self) new-value))
+
+(def-c-output m-ephem-b ()
+ (setf (m-test-b self) new-value))
+
+(def-cell-test m-ephem
+ (let ((m (make-be 'm-ephem :m-ephem-a (c-in nil) :m-ephem-b (c? (* 2 (or (^m-ephem-a) 0))))))
+ (ct-assert (null (slot-value m 'm-ephem-a)))
+ (ct-assert (null (m-ephem-a m)))
+ (ct-assert (null (m-test-a m)))
+ (ct-assert (null (slot-value m 'm-ephem-b)))
+ (ct-assert (null (m-ephem-b m)))
+ (ct-assert (zerop (m-test-b m)))
+ (setf (m-ephem-a m) 3)
+ (ct-assert (null (slot-value m 'm-ephem-a)))
+ (ct-assert (null (m-ephem-a m)))
+ (ct-assert (eql 3 (m-test-a m)))
+ ;
+ (ct-assert (null (slot-value m 'm-ephem-b)))
+ (ct-assert (null (m-ephem-b m)))
+ (ct-assert (eql 6 (m-test-b m)))
+ ))
+
+
+
Added: dependencies/trunk/cells/test-propagation.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/test-propagation.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,45 @@
+(in-package :cells)
+
+(defmd tcp ()
+ (left (c-in 0))
+ (top (c-in 0))
+ (right (c-in 0))
+ (bottom (c-in 0))
+ (area (c? (trc "area running")
+ (* (- (^right)(^left))
+ (- (^top)(^bottom))))))
+
+(defobserver area ()
+ (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*))
+
+(defobserver bottom ()
+ (TRC "new bottom" new-value old-value old-value-boundp :pulse *data-pulse-id*)
+ (with-integrity (:change 'bottom-tells-left)
+ (setf (^left) new-value)))
+
+(defobserver left ()
+ (TRC "new left" new-value old-value old-value-boundp :pulse *data-pulse-id*))
+
+(defun tcprop ()
+ (untrace)
+ (ukt:test-prep)
+ (LET ((box (make-instance 'tcp)))
+ (trc "changing top to 10" *data-pulse-id*)
+ (setf (top box) 10)
+ (trc "not changing top" *data-pulse-id*)
+ (setf (top box) 10)
+ (trc "changing right to 10" *data-pulse-id*)
+ (setf (right box) 10)
+ (trc "not changing right" *data-pulse-id*)
+ (setf (right box) 10)
+ (trc "changing bottom to -1" *data-pulse-id*)
+ (decf (bottom box))
+ (with-one-datapulse ()
+ (loop repeat 5 do
+ (trc "changing bottom by -1" *data-pulse-id*)
+ (decf (bottom box))))))
+
+
+
+
+
Added: dependencies/trunk/cells/test-synapse.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/test-synapse.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,102 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+
+(defmodel m-syn ()
+ ((m-syn-a :initform nil :initarg :m-syn-a :accessor m-syn-a)
+ (m-syn-b :initform nil :initarg :m-syn-b :accessor m-syn-b)
+ (m-syn-factor :initform nil :initarg :m-syn-factor :accessor m-syn-factor)
+ (m-sens :initform nil :initarg :m-sens :accessor m-sens)
+ (m-plus :initform nil :initarg :m-plus :accessor m-plus)
+ ))
+
+(def-c-output m-syn-b ()
+ (print `(output m-syn-b ,self ,new-value ,old-value)))
+
+
+
+(def-cell-test m-syn
+ (progn (cell-reset)
+ (let* ((delta-ct 0)
+ (sens-ct 0)
+ (plus-ct 0)
+ (m (make-be 'm-syn
+ :m-syn-a (c-in 0)
+ :m-syn-b (c? (incf delta-ct)
+ (trc nil "syn-b rule firing!!!!!!!!!!!!!!" delta-ct)
+ (eko (nil "syn-b rule returning")
+ (f-delta :syna-1 (:sensitivity 2)
+ (^m-syn-a))))
+ :m-syn-factor (c-in 1)
+ :m-sens (c? (incf sens-ct)
+ (trc nil "m-sens rule firing ~d !!!!!!!!!!!!!!" sens-ct)
+ (* (^m-syn-factor)
+ (f-sensitivity :sensa (3) (^m-syn-a))))
+ :m-plus (c? (incf plus-ct)
+ (trc nil "m-plus rule firing!!!!!!!!!!!!!!" plus-ct)
+ (f-plusp :syna-2 (- 2 (^m-syn-a)))))))
+ (ct-assert (= 1 delta-ct))
+ (ct-assert (= 1 sens-ct))
+ (ct-assert (= 1 plus-ct))
+ (ct-assert (= 0 (m-sens m)))
+ (trc "make-be complete. about to incf m-syn-a")
+ (incf (m-syn-a m))
+ (ct-assert (= 1 delta-ct))
+ (ct-assert (= 1 sens-ct))
+ (ct-assert (= 1 plus-ct))
+ (ct-assert (= 0 (m-sens m)))
+ (trc "about to incf m-syn-a 2")
+ (incf (m-syn-a m) 2)
+ (trc nil "syn-b now" (m-syn-b m))
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (= 2 sens-ct))
+ (ct-assert (= 2 plus-ct))
+
+ (ct-assert (= 3 (m-sens m)))
+ (trc "about to incf m-syn-a")
+ (incf (m-syn-a m))
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (= 2 sens-ct))
+ (trc "about to incf m-syn-factor")
+ (incf (m-syn-factor m))
+ (ct-assert (= 3 sens-ct))
+ (ct-assert (= (m-sens m) (* (m-syn-factor m) (m-syn-a m))))
+ (trc "about to incf m-syn-a xxx")
+ (incf (m-syn-a m))
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (= 3 sens-ct))
+ (trc "about to incf m-syn-a yyyy")
+ (incf (m-syn-a m))
+ (ct-assert (= 3 delta-ct))
+ (ct-assert (= 4 sens-ct))
+ (ct-assert (= 2 plus-ct))
+ (describe m)
+ (print '(start)))))
+
+(Def-c-output m-syn-a ()
+ (trc "!!! M-SYN-A now =" new-value))
+
+#+(or)
+(m-syn)
+
Added: dependencies/trunk/cells/test.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/test.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,228 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+#| Synapse Cell Unification Notes
+
+- start by making Cells synapse-y
+
+- make sure outputs show right old and new values
+- make sure outputs fire when they should
+
+- wow: test the Cells II dictates: no output callback sees stale data, no rule
+sees stale data, etc etc
+
+- test a lot of different synapses
+
+- make sure they fire when they should, and do not when they should not
+
+- make sure they survive an evaluation by the caller which does not branch to
+them (ie, does not access them)
+
+- make sure they optimize away
+
+- test with forms which access multiple other cells
+
+- look at direct alteration of a caller
+
+- does SETF honor not propagating, as well as a c-ruled after re-calcing
+
+- do diff unchanged tests such as string-equal work
+
+|#
+
+#| do list
+
+-- can we lose the special handling of the .kids slot?
+
+-- test drifters (and can they be handled without creating a special
+subclass for them?)
+
+|#
+
+(eval-when (compile load)
+ (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3))))
+
+(in-package :cells)
+
+(defvar *cell-tests* nil)
+
+
+#+go
+(test-cells)
+
+(defun test-cells ()
+ (loop for test in (reverse *cell-tests*)
+ do (cell-test-init test)
+ (funcall test)))
+
+(defun cell-test-init (name)
+ (print (make-string 40 :initial-element #\!))
+ (print `(starting test ,name))
+ (print (make-string 40 :initial-element #\!))
+ (cell-reset))
+
+(defmacro def-cell-test (name &rest body)
+ `(progn
+ (pushnew ',name *cell-tests*)
+ (defun ,name ()
+ (cell-reset)
+ , at body)))
+
+(defmacro ct-assert (form &rest stuff)
+ `(progn
+ (print `(attempting ,',form))
+ (assert ,form () "Error with ~a >> ~a" ',form (list , at stuff))))
+
+;; test huge number of useds by one rule
+
+(defmodel m-index (family)
+ ()
+ (:default-initargs
+ :value (c? (bwhen (ks (^kids))
+ (apply '+ (mapcar 'value ks))))))
+
+(def-cell-test many-useds
+ (let ((i (make-instance 'm-index)))
+ (loop for n below 100
+ do (push (make-instance 'model
+ :value (c-in n))
+ (kids i)))
+ (trc "index total" (value i))))
+
+(defmodel m-null ()
+ ((aa :initform nil :cell nil :initarg :aa :accessor aa)))
+
+(def-cell-test m-null
+ (let ((m (make-be 'm-null :aa 42)))
+ (ct-assert (= 42 (aa m)))
+ (ct-assert (= 21 (decf (aa m) 21)))
+ :okay-m-null))
+
+(defmodel m-solo ()
+ ((m-solo-a :initform nil :initarg :m-solo-a :accessor m-solo-a)
+ (m-solo-b :initform nil :initarg :m-solo-b :accessor m-solo-b)))
+
+(def-cell-test m-solo
+ (let ((m (make-be 'm-solo
+ :m-solo-a (c-in 42)
+ :m-solo-b (c? (* 2 (^m-solo-a))))))
+ (ct-assert (= 42 (m-solo-a m)))
+ (ct-assert (= 84 (m-solo-b m)))
+ (decf (m-solo-a m))
+ (ct-assert (= 41 (m-solo-a m)))
+ (ct-assert (= 82 (m-solo-b m)))
+ :okay-m-null))
+
+(defmodel m-var ()
+ ((m-var-a :initform nil :initarg :m-var-a :accessor m-var-a)
+ (m-var-b :initform nil :initarg :m-var-b :accessor m-var-b)))
+
+(def-c-output m-var-b ()
+ (print `(output m-var-b ,self ,new-value ,old-value)))
+
+(def-cell-test m-var
+ (let ((m (make-be 'm-var :m-var-a (c-in 42) :m-var-b 1951)))
+ (ct-assert (= 42 (m-var-a m)))
+ (ct-assert (= 21 (decf (m-var-a m) 21)))
+ (ct-assert (= 21 (m-var-a m)))
+ :okay-m-var))
+
+(defmodel m-var-output ()
+ ((cbb :initform nil :initarg :cbb :accessor cbb)
+ (aa :cell nil :initform nil :initarg :aa :accessor aa)))
+
+(def-c-output cbb ()
+ (trc "output cbb" self)
+ (setf (aa self) (- new-value (if old-value-boundp
+ old-value 0))))
+
+(def-cell-test m-var-output
+ (let ((m (make-be 'm-var-output :cbb (c-in 42))))
+ (ct-assert (eql 42 (cbb m)))
+ (ct-assert (eql 42 (aa m)))
+ (ct-assert (eql 27 (decf (cbb m) 15)))
+ (ct-assert (eql 27 (cbb m)))
+ (ct-assert (eql -15 (aa m)))
+ (list :okay-m-var (aa m))))
+
+(defmodel m-var-linearize-setf ()
+ ((ccc :initform nil :initarg :ccc :accessor ccc)
+ (ddd :initform nil :initarg :ddd :accessor ddd)))
+
+(def-c-output ccc ()
+ (with-deference
+ (setf (ddd self) (- new-value (if old-value-boundp
+ old-value 0)))))
+
+(def-cell-test m-var-linearize-setf
+ (let ((m (make-be 'm-var-linearize-setf
+ :ccc (c-in 42)
+ :ddd (c-in 1951))))
+
+ (ct-assert (= 42 (ccc m)))
+ (ct-assert (= 42 (ddd m)))
+ (ct-assert (= 27 (decf (ccc m) 15)))
+ (ct-assert (= 27 (ccc m)))
+ (ct-assert (= -15 (ddd m)))
+ :okay-m-var))
+
+;;; -------------------------------------------------------
+
+(defmodel m-ruled ()
+ ((eee :initform nil :initarg :eee :accessor eee)
+ (fff :initform (c? (floor (^ccc) 2)) :initarg :fff :accessor fff)))
+
+(def-c-output eee ()
+ (print `(output> eee ,new-value old ,old-value)))
+
+(def-c-output fff ()
+ (print `(output> eee ,new-value old ,old-value)))
+
+(def-cell-test m-ruled
+ (let ((m (make-be 'm-ruled
+ :eee (c-in 42)
+ :fff (c? (floor (^eee) 2)))))
+ (trc "___Initial TOBE done____________________")
+ (print `(pulse ,*data-pulse-id*))
+ (ct-assert (= 42 (eee m)))
+ (ct-assert (= 21 (fff m)))
+ (ct-assert (= 36 (decf (eee m) 6)))
+ (print `(pulse ,*data-pulse-id*))
+ (ct-assert (= 36 (eee m)))
+ (ct-assert (= 18 (fff m)) m)
+ :okay-m-ruled))
+
+(defmodel m-worst-case ()
+ ((wc-x :accessor wc-x :initform (c-input () 2))
+ (wc-a :accessor wc-a :initform (c? (when (oddp (wc-x self))
+ (wc-c self))))
+ (wc-c :accessor wc-c :initform (c? (evenp (wc-x self))))
+ (wc-h :accessor wc-h :initform (c? (or (wc-c self)(wc-a self))))))
+
+(def-cell-test m-worst-case
+ (let ((m (make-be 'm-worst-case)))
+ (trc "___Initial TOBE done____________________")
+ (ct-assert (eql t (wc-c m)))
+ (ct-assert (eql nil (wc-a m)))
+ (ct-assert (eql t (wc-h m)))
+ (ct-assert (eql 3 (incf (wc-x m))))))
+
Added: dependencies/trunk/cells/trc-eko.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/trc-eko.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,170 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ The Newly Cells-aware TRC trace and EKO value echo facilities
+
+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 :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)
+ (if (stringp tgt-form)
+ `(without-c-dependency
+ (call-trc t ,tgt-form , at os))
+ (let ((tgt (gensym)))
+ ;(break "slowww? ~a" tgt-form)
+ `(without-c-dependency
+ (bif (,tgt ,tgt-form)
+ (if (trcp ,tgt)
+ (progn
+ (assert (stringp ,(car os)) () "trc with test expected string second, got ~a" ,(car os))
+ (call-trc t , at os)) ;;,(car os) ,tgt ,@(cdr os)))
+ (progn
+ ;(trc "trcfailed")
+ (count-it :trcfailed)))
+ (count-it :tgtnileval)))))))
+
+(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 bgo)
+
+(define-symbol-macro .bgo
+ #+gimme-a-break (break "go")
+ #-gimme-a-break nil)
+
+(defmacro bgo (msg)
+ (declare (ignorable msg))
+ #+gimme-a-break `(break "BGO ~a" ',msg)
+ #-gimme-a-break `(progn))
+
+(defmacro brkx (msg)
+ (declare (ignorable msg))
+ #+gimme-a-break `(break "At ~a: OK?" ',msg)
+ #-gimme-a-break `(progn))
+
+(defmacro trcx (tgt-form &rest os)
+ (if (eql tgt-form 'nil)
+ '(progn)
+ `(without-c-dependency
+ (call-trc t ,(format nil "TX> ~(~s~)" tgt-form)
+ ,@(loop for obj in (or os (list tgt-form))
+ nconcing (list (intern (format nil "~a" obj) :keyword) obj))))))
+
+(defun call-trc-to-string (fmt$ &rest fmt-args)
+ (let ((o$ (make-array '(0) :element-type 'base-char
+ :fill-pointer 0 :adjustable t)))
+ (with-output-to-string (os-stream o$)
+ (apply 'call-trc os-stream fmt$ fmt-args))
+ o$))
+
+#+findtrcevalnils
+(defmethod trcp :around (other)
+ (unless (call-next-method other)(break)))
+
+(defmethod trcp (other)
+ (eq other t))
+
+(defmethod trcp (($ string))
+ t)
+
+(defun trcdepth-incf ()
+ (incf *trcdepth*))
+
+(defun trcdepth-decf ()
+ (format t "decrementing trc depth ~d" *trcdepth*)
+ (decf *trcdepth*))
+
+(defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body )
+ `(let ((*trcdepth* (if *trcdepth*
+ (1+ *trcdepth*)
+ 0)))
+ ,(when banner `(when (>= *trcdepth* ,min)
+ (if (< *trcdepth* ,max)
+ (trc , at banner)
+ (progn
+ (break "excess trace notttt!!! ~d" *trcdepth*) ;; , at banner)
+ nil))))
+ (when (< *trcdepth* ,max)
+ , at body)))
+
+(defmacro wtrcx ((&key (min 1) (max 50) (on? t))(&rest banner) &body body )
+ `(let ((*trcdepth* (if *trcdepth*
+ (1+ *trcdepth*)
+ 0)))
+ ,(when banner `(when (and ,on? (>= *trcdepth* ,min))
+ (if (< *trcdepth* ,max)
+ (trc , at banner)
+ (progn
+ (break "excess trace notttt!!! ~d" *trcdepth*) ;; , at banner)
+ nil))))
+ (when (< *trcdepth* ,max)
+ , at body)))
+
+(defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body )
+ (declare (ignore min max banner))
+ `(progn , at body))
+
+;------ eko --------------------------------------
+
+(defmacro eko ((&rest trcargs) &rest body)
+ (let ((result (gensym)))
+ `(let ((,result , at body))
+ ,(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)
+ (let ((result (gensym)))
+ `(let ((,result (, at body)))
+ (trc ,(string-downcase (symbol-name ekx-id)) :=> ,result)
+ ,result)))
+
+(defmacro eko-if ((&rest trcargs) &rest body)
+ (let ((result (gensym)))
+ `(let ((,result , at body))
+ (when ,result
+ (trc ,(car trcargs) :res ,result ,@(cdr trcargs)))
+ ,result)))
+
+(defmacro ek (label &rest body)
+ (let ((result (gensym)))
+ `(let ((,result (, at body)))
+ (when ,label
+ (trc ,label ,result))
+ ,result)))
+
Added: dependencies/trunk/cells/tutorial/01-lesson.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/01-lesson.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,40 @@
+(defmacro cells::ct-assert (form &rest stuff)
+ `(progn
+ (print `(attempting ,',form))
+ (assert ,form () "Error with ~a >> ~a" ',form (list , at stuff))))
+
+(defpackage #:tu-selfinit (:use :cl :cells))
+
+;;
+;; We will keep making new packages so we can incrementally develop the
+;; same class without newer versions stomping on earlier versions (by
+;; being in the same package and effectively redefining earlier versions).
+;;
+(in-package #:tu-selfinit)
+
+(defmodel rectangle ()
+ ((len :initarg :len :accessor len
+ :initform (c? (* 2 (width self))))
+ (width :initarg :width :initform nil :accessor width))
+ (:default-initargs
+ :width (c? (/ (len self) 2))))
+
+#+test
+(cells::ct-assert (eql 21 (width (make-instance 'rectangle :len 42))))
+
+;;; The first thing we see is that we are not creating something new, we are
+;;; merely /extending/ CLOS. defmodel works like defclass in all ways, except for
+;;; extensions to provide the behavior of Cells. We see both :initform
+;;; and :default-initarg used to provide rules for a slot. We also see
+;;; the initarg :len used to override the default initform.
+;;;
+;;; By extending defclass we (a) retain its expressiveness, and (b) produce
+;;; something hopefully easier to learn by developers already familiar with CLOS.
+;;;
+;;; The first extension we see is that the len initform refers to the
+;;; Smalltalk-like anaphoric variable self, to which will be bound
+;;; the rectangle instance being initialized. Normally an initform is evaluated
+;;; without being able to see the instance, and any initialization requiring
+;;; that must be done in the class initializer.
+
+
Added: dependencies/trunk/cells/tutorial/01a-dataflow.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/01a-dataflow.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,17 @@
+(defpackage #:tu-dataflow (:use :cl :cells))
+(in-package #:tu-dataflow)
+
+(defmodel rectangle ()
+ ((len :initarg :len :accessor len
+ :initform (c? (* 2 (width self))))
+ (width :initarg :width :initform nil :accessor width))
+ (:default-initargs
+ :width (c? (/ (len self) 2))))
+
+#+test
+(let ((r (make-instance 'rectangle :len (c-in 42))))
+ (cells::ct-assert (eql 21 (width r)))
+ (cells::ct-assert (= 1000 (setf (len r) 1000))) ;; make sure we did not break SETF, which must return the value set
+ (cells::ct-assert (eql 500 (width r)))) ;; make sure new value propagated
+
+
Added: dependencies/trunk/cells/tutorial/01b-change-handling.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/01b-change-handling.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,36 @@
+#| There is the fun part: automatic state management. Not only can a slot get its value from
+a self-aware rule, but that value will stay current with other values as they change.
+
+But often changes to a value must be reflected outside the automatic dataflow model. See next.
+
+|#
+
+(defpackage #:tu-change-handling (:use :cl :cells))
+(in-package #:tu-change-handling)
+
+(defmodel rectangle ()
+ ((len :initarg :len :accessor len
+ :initform (c? (* 2 (width self))))
+ (width :initarg :width :initform nil :accessor width))
+ (:default-initargs
+ :width (c? (/ (len self) 2))))
+
+(defvar *gui-told*)
+
+(defobserver len ((self rectangle) new-value old-value old-value-bound-p)
+ ;; Where rectangle is a GUI element, we need to tell the GUI framework
+ ;; to update this area of the screen
+ (setf *gui-told* t)
+ (print (list "tell GUI about" self new-value old-value old-value-bound-p)))
+
+#+test
+(let* ((*gui-told* nil)
+ (r (make-instance 'rectangle :len (c-in 42))))
+ (cells::ct-assert *gui-told*)
+ (setf *gui-told* nil)
+ (cells::ct-assert (eql 21 (width r)))
+
+ (cells::ct-assert (= 1000 (setf (len r) 1000)))
+ (cells::ct-assert *gui-told*)
+ (cells::ct-assert (eql 500 (width r))))
+
Added: dependencies/trunk/cells/tutorial/01c-cascade.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/01c-cascade.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,94 @@
+#|
+
+Now we have automatic state management (including change propagation)
+outside the Cells model as well as in. Now lets look at cascading change
+by adding another level of computation, so A->B->C.
+
+In this case: len->area->brightness
+Also: len->width->area->brightness
+
+That leads to some complications I will discuss, but no assertions here
+enforce correct behavior in re those complications. Soon. :)
+
+|#
+
+(defpackage #:tu-depth (:use :cl :cells))
+(in-package #:tu-depth)
+
+(defmacro start-finish (key rule)
+ `(progn
+ (print (list :start ,key))
+ (prog1
+ (progn ,rule)
+ (print (list :finish ,key)))))
+
+(defmodel rectangle ()
+ ((lumens :initform 1000000 :reader lumens)
+ (len :initarg :len :accessor len
+ :initform (c? (start-finish :len
+ (* 2 (width self)))))
+ (area :initarg :area :accessor area
+ :initform (c? (start-finish :area
+ (* (len self)(width self)))))
+ (width :initarg :width :accessor width
+ :initform (c? (start-finish :width
+ (floor (len self) 2))))
+ (brightness :reader brightness
+ :initform (c? (start-finish :brightness
+ (/ (^lumens) (^area)))))
+ ))
+
+#+test
+(let ((r (make-instance 'rectangle :len (c-in 100))))
+ (cells::ct-assert (eql 50 (width r)))
+ (cells::ct-assert (eql 5000 (area r)))
+ (cells::ct-assert (eql 200 (brightness r)))
+ (cells::ct-assert (= 1000 (setf (len r) 1000)))
+ (cells::ct-assert (eql 500000 (area r)))
+ (cells::ct-assert (eql 2 (brightness r))))
+
+#| --- discussion ----------------------------
+
+The output in Cells is:
+
+(:START :AREA)
+(:START :WIDTH)
+(:finish :WIDTH)
+(:finish :AREA)
+(:START :BRIGHTNESS)
+(:finish :BRIGHTNESS)
+(CELTK::ATTEMPTING (EQL 50 (WIDTH R)))
+(CELTK::ATTEMPTING (EQL 5000 (AREA R)))
+(CELTK::ATTEMPTING (EQL 200 (BRIGHTNESS R)))
+(CELTK::ATTEMPTING (= 1000 (SETF (LEN R) 1000)))
+0> c-propagate-to-users > notifying users of | [i :=[24]LEN/#<RECTANGLE>] | (AREA WIDTH)
+
+Notice here that the LEN cell is about to tell both the width and area to recalculate,
+since area depends (of course) on len and (rather artificially) width also derives
+from LEN.
+
+ie, This example has accidentally deviated into more complexity than intended. But we are
+approaching these issues anyay, so I will leave it for now. We can always break it up
+later.
+
+Let's continue:
+
+(:START :WIDTH)
+(:finish :WIDTH)
+(:START :AREA)
+(:finish :AREA)
+
+Fine, now here comes the challenge. Width is also going to tell area to recalculate:
+
+0> c-propagate-to-users > notifying users of | [? :<vld>=[24]WIDTH/#<RECTANGLE>] | (AREA)
+0> c-propagate-to-users > notifying users of | [? :<vld>=[24]AREA/#<RECTANGLE>] | (BRIGHTNESS)
+
+Correct: Area does not actually run its rule since it already did so when notified by LEN,
+ but it does propagate to brightness.
+
+(:START :BRIGHTNESS)
+(:finish :BRIGHTNESS)
+(CELTK::ATTEMPTING (EQL 500000 (AREA R)))
+(CELTK::ATTEMPTING (EQL 2 (BRIGHTNESS R)))
+
+|#
\ No newline at end of file
Added: dependencies/trunk/cells/tutorial/02-lesson.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/02-lesson.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,63 @@
+#| A->B->C works. For efficiency, let's have propagation stop if some rule
+computes the same value as last time.
+|#
+
+(defpackage #:tu-smart-propagation (:use :cl :cells :utils-kt :tu-cells))
+(in-package #:tu-smart-propagation)
+
+
+;;; -----------------------------------------------
+
+(defmodel rectangle ()
+ ((padded-width :initarg :padded-width :accessor padded-width
+ :initform (c? (compute-log :padded-width)
+ (+ 10 (width self))))
+ (len :initarg :len :accessor len
+ :initform (c? (compute-log :len)
+ (* 2 (width self))))
+ (width :initarg :width :accessor width
+ :initform (c? (compute-log :width)
+ (floor (len self) 2)))))
+
+(defobserver width ()
+ (assert (not (eql new-value old-value)))
+ (TRC "observing width" new-value old-value)
+ (compute-log :width-observer))
+
+(defobserver len ()
+ (compute-log :len-observer))
+
+#+test
+(let* ((r (progn
+ (CELLS-RESET)
+ (clear-computed)
+ (make-instance 'rectangle :len (c-in 42)))))
+ (cells::ct-assert (eql 21 (width r)))
+
+ ;; first check that setting an input cell does not
+ ;; propagate needlessly...
+
+ (clear-computed)
+ (verify-not-computed :len-observer :width :width-observer :padded-width)
+ (setf (len r) 42) ;; n.b. same as existing value, no change
+ (cells::ct-assert (eql 21 (width r))) ;; floor truncates
+ (verify-not-computed :len-observer :width :width-observer :padded-width)
+
+ ;; now check that intermediate computations, when unchanged
+ ;; from the preceding computation, does not propagate needlessly...
+
+ (clear-computed)
+ (setf (len r) 43)
+ (cells::ct-assert (eql 21 (width r))) ;; floor truncates
+ (verify-computed :len-observer :width)
+ (verify-not-computed :width-observer :padded-width)
+
+ #| Ok, so the engine runs the width rule, sees that it computes
+the same value as before, so does not invoke either the width
+observer or recalculation of are. Very efficient. The sanity check
+reconfirms that the engine does do that work when necessary.
+|#
+
+ (clear-computed)
+ (setf (len r) 44)
+ (verify-computed :len-observer :width :width-observer :padded-width))
Added: dependencies/trunk/cells/tutorial/03-ephemeral.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/03-ephemeral.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,85 @@
+
+
+(defpackage #:tu-ephemeral (:use :cl :utils-kt :cells :tu-cells))
+(in-package #:tu-ephemeral)
+
+
+#|
+
+Events present a problem for spreadsheet models. Suppose we have a clicked rule for a button
+which says:
+
+ :clicked (c? (point-in-rect
+ (screen-location (mouse-event *window*))
+ (bounding-box self)))
+
+Now suppose we get a mouse-event outside the bounding box of widget X, and then in the
+next application event something happens that makes the bounding box grow such that it
+includes the location of the old mouse event. We need the mouse-event not to be there any more,
+because, well, events are events. It is relevant only in the moment of its creation and propagation.
+
+Note, btw, that this must happen not as bang-bang:
+
+ (setf (mouse-event *window*) (get-next-event)
+ (setf (mouse-event *window*) nil)
+
+...because observers can kick off state change, and anyway SETF has interesting Cell semantics,
+including observers firing. So setf-nil is a kludge, better that the Cells engine acknowledge that
+events are different and accomodate them by silently reverting an event to nil as soon as it finishes
+propagating.
+
+Finally, so far this has worked out well as a slot attribute as defined at the class level, not
+instance by instance, by specifying :cell :ephemeral
+
+|#
+
+(defmodel rectangle ()
+ ((click :cell :ephemeral :initform (c-in nil) :accessor click)
+ (bbox :initarg :bbox :initform (c-in nil) :accessor bbox)
+ (clicked :cell :ephemeral :accessor clicked
+ :initform (c? (point-in-rect (^click)(^bbox))))))
+
+(defun point-in-rect (p r)
+ (when (and p r)
+ (destructuring-bind (x y) p
+ (destructuring-bind (l top r b) r
+ (and (<= l x r)
+ (<= b y top))))))
+
+(defobserver click ((self rectangle) new-value old-value old-value-bound-p)
+ (when new-value
+ (with-integrity (:change)
+ (TRC "setting bbox!!!")
+ (setf (bbox self) (list -1000 1000 1000 -1000)))))
+
+(defobserver clicked ((self rectangle) new-value old-value old-value-bound-p)
+ (when new-value
+ (TRC "clicked!!!!" self new-value)
+ (compute-log :clicked)))
+
+#+test
+(progn
+ (cells-reset)
+ (let* ((starting-bbox (list 10 10 20 20))
+ (r (make-instance 'rectangle
+ :bbox (c-in (list 10 10 20 20)))))
+ (clear-computed)
+ (setf (click r) (list 0 0))
+ (assert (and (not (point-in-rect (list 0 0) starting-bbox))
+ (point-in-rect (list 0 0)(bbox r))
+ (verify-not-computed :clicked)))))
+
+#|
+The assertion demonstrates... well, it is complicated. Point 0-0 is
+in the current bbox, but the system correctly determines that it
+was not clicked. The click event at 0-0 happened when the bbox
+was elsewhwer. When the bbox moved, the Cells engine had already cleared
+the "ephemeral" click.
+
+Note that now we have less transparency: if one wants to perturb the data model
+from with an observer of some ongoing perturbation, one needs to arrange for
+that nested perturbation to wait until the ongoing one completes. That
+explains the "with-integrity" macro.
+
+|#
+
\ No newline at end of file
Added: dependencies/trunk/cells/tutorial/04-formula-once-then-input.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/04-formula-once-then-input.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,48 @@
+
+
+(defpackage #:tu-rule-once-then-input (:use :cl :utils-kt :cells :tu-cells))
+(in-package #:tu-rule-once-then-input)
+
+
+#|
+
+Often in interactive applications one needs to do interesting things to come up
+with an initial value for a field which then is to be edited by a user, or
+for some other reason regularly fed as a C-INPUT.
+
+|#
+
+(defvar *db-entry*)
+
+(defun get-age (id)
+ (bwhen (props (cdr (assoc id *db-entry* :test 'string=)))
+ (getf props :age)))
+
+(defmodel kenny-view ()
+ ((age :accessor age :initform (c-formula (:inputp t)
+ (- (get-age "555-55-5555")
+ (^grecian-formula-amt))))
+ (grecian-formula-amt :accessor grecian-formula-amt
+ :initform (c-in 5))))
+
+(defobserver age ((self kenny-view))
+ (setf (getf (cdr (assoc "555-55-5555" *db-entry* :test 'string=)) :age) new-value))
+
+#+test
+(let ((*db-entry* (copy-list '(("555-55-5555" . (:name "ken" :age 54))
+ ("666-66-6666" . (:name "satan" :age most-positive-fixnum))))))
+ (cells-reset)
+ (let ((kv (make-instance 'kenny-view)))
+ (print `(:age-init ,(age kv)))
+ (assert (= 49 (age kv)))
+
+ (incf (grecian-formula-amt kv) 10) ;; try looking younger
+ (assert (= 15 (grecian-formula-amt kv)))
+
+ (assert (= 49 (age kv))) ;; unchanged -- the age rule is gone
+
+ (print `(:happy-birthday ,(incf (age kv))))
+ (assert (= 50 (age kv)(get-age "555-55-5555")))
+ ;
+ ; just showin' off...
+ (assert (= 51 (1+ (age kv))(incf (age kv))(get-age "555-55-5555")))))
\ No newline at end of file
Added: dependencies/trunk/cells/tutorial/test.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/test.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,52 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(eval-when (compile load)
+ (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3))))
+
+(defpackage #:tu-cells
+ (:use :cl :utils-kt)
+ (:export #:clear-computed #:verify-computed #:verify-not-computed #:compute-log))
+
+(in-package :tu-cells)
+
+(defmacro ct-assert (form &rest stuff)
+ `(progn
+ (print `(attempting ,',form))
+ (assert ,form () "Error with ~a >> ~a" ',form (list , at stuff))))
+
+(defvar *computed*)
+(defun clear-computed ()
+ (setf *computed* nil))
+
+(defun compute-log (&rest keys)
+ (loop for k in keys
+ do (pushnew k *computed*)))
+
+(defun verify-computed (&rest keys)
+ (loop for k in keys
+ do (assert (find k *computed*)() "Unable verify ~a computed: ~a" k *computed*)))
+
+(defun verify-not-computed (&rest keys)
+ (loop for k in keys
+ do (assert (not (find k *computed*)) () "Unable verify ~a NOT computed: ~a" k *computed*)
+ finally (return t)))
\ No newline at end of file
Added: dependencies/trunk/cells/tutorial/tutorial.lpr
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/tutorial.lpr Tue Jan 26 15:20:07 2010
@@ -0,0 +1,95 @@
+;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*-
+
+(in-package :cg-user)
+
+(defpackage :TU-CELLS)
+
+(define-project :name :tutorial
+ :modules (list (make-instance 'module :name "test.lisp")
+ (make-instance 'module :name "01-lesson.lisp")
+ (make-instance 'module :name "01a-dataflow.lisp")
+ (make-instance 'module :name
+ "01b-change-handling.lisp")
+ (make-instance 'module :name "01c-cascade.lisp")
+ (make-instance 'module :name "02-lesson.lisp")
+ (make-instance 'module :name "03-ephemeral.lisp")
+ (make-instance 'module :name
+ "04-formula-once-then-input.lisp")
+ (make-instance 'module :name "05-class-cell.lisp")
+ (make-instance 'module :name
+ "..\\gotchas\\lost-ephemeral-init.lisp")
+ (make-instance 'module :name "chat-cells.lisp")
+ (make-instance 'module :name "df-interference.lisp"))
+ :projects (list (make-instance 'project-module :name "..\\cells"))
+ :libraries nil
+ :distributed-files nil
+ :internally-loaded-files nil
+ :project-package-name :tu-cells
+ :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)
+ :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)
+ :autoload-warning t
+ :full-recompile-for-runtime-conditionalizations nil
+ :default-command-line-arguments "+M +t \"Console for Debugging\""
+ :additional-build-lisp-image-arguments '(:read-init-files nil)
+ :old-space-size 256000
+ :new-space-size 6144
+ :runtime-build-option :standard
+ :on-initialization 'tu-cells::tu-chat-2
+ :on-restart 'do-default-restart)
+
+;; End of Project Definition
Added: dependencies/trunk/cells/utils-kt/core.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/core.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,74 @@
+#|
+
+ 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 with-gensyms ((&rest symbols) &body body)
+ `(let ,(loop for sym in symbols
+ collecting `(,sym (gensym ,(string sym))))
+ , at body))
+
+(defmacro eval-now! (&body body)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ , at body))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmacro export! (&rest symbols)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export ',symbols))))
+
+(eval-now!
+ (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)))))
+
+(defun test-setup (&optional drib)
+ #+(and allegro ide (or (not its-alive!) debugging-alive!))
+ (ide.base::find-new-prompt-command
+ (cg.base::find-window :listener-frame))
+ (when drib
+ (dribble (merge-pathnames
+ (make-pathname :name drib :type "TXT")
+ (project-path)))))
+
+(export! test-setup test-prep test-init)
+(export! project-path)
+(defun project-path ()
+ #+(and allegro ide (not its-alive!))
+ (excl:path-pathname (ide.base::project-file ide.base:*current-project*))
+ )
+
+#+test
+(test-setup)
+
+(defun test-prep (&optional drib)
+ (test-setup drib))
+
+(defun test-init (&optional drib)
+ (test-setup drib))
\ No newline at end of file
Added: dependencies/trunk/cells/utils-kt/datetime.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/datetime.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,205 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*-
+#|
+
+ Utils-kt
+
+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)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(os-tickcount time-of-day now hour-min-of-day
+ time-in-zone dd-mmm-yy mmm-dd-yyyy)))
+
+(defun os-tickcount ()
+ (cl:get-internal-real-time))
+
+(defun now ()
+ (/ (get-internal-real-time)
+ internal-time-units-per-second))
+
+(defun time-of-day (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~A:~2,,,'0 at A:~2,,,'0 at A" hours minutes seconds)))
+
+(defun hour-min-of-day (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~2,,,'0 at A:~2,,,'0 at A" hours minutes)))
+
+(defun time-in-zone (inzone &optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylightsavingsp this-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable this-zone day-of-week daylightsavingsp))
+ (encode-universal-time seconds minutes hours date month year (- inzone (if daylightsavingsp 1 0)))))
+
+(defun dd-mmm-yy (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~A-~A-~2,,,'0 at A" date (month-abbreviation month)
+ (mod year 100))))
+
+(defun mmm-dd-yyyy (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~A ~A, ~A" (month-abbreviation month)
+ date year)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(month-abbreviation weekday-abbreviation week-time
+ mdyy-yymd u-time u-date)))
+
+(defun month-abbreviation (month)
+ (elt '("Jan" "Feb" "Mar" "Apr" "May" "June"
+ "July" "Aug" "Sept" "Oct" "Nov" "Dec") (1- month)))
+
+(defun weekday-abbreviation (day)
+ (elt '("Mon" "Tue" "Wed" "Thur" "Fri" "Sat" "Sun") day))
+
+(defun week-time (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~A ~A ~A, ~A ~a:~2,'0d ~a"
+ (weekday-abbreviation day-of-week)
+ (month-abbreviation month)
+
+ date
+ year
+ (if (= 12 hours) hours (mod hours 12)) ; JP 010911 since (mod 12 12) = 0, treat 12 as a special case.
+ minutes (if (>= hours 12) "PM" "AM"))))
+
+
+(defun mdyy-yymd (d)
+ (assert (eql 8 (length d)))
+ (conc$ (right$ d 4) (left$ d 4)))
+
+(defun u-time (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~2,d:~2,'0d ~a"
+ ;; /// time-zone, really Naggum's stuff
+ (mod hours 12) minutes
+ (if (>= hours 12) "PM" "AM"))))
+
+(defun u-date (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~A-~A-~A"
+ date
+ (elt '("Jan" "Feb" "Mar" "Apr" "May" "June"
+ "July" "Aug" "Sept" "Oct" "Nov" "Dec") (1- month))
+ year
+ )))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(u-day multiple-value-bind m/d/y mm/dd yyyy-mm-dd)))
+
+(defun u-day (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (elt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") day-of-week)))
+
+(defun u-day3 (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (elt '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") day-of-week)))
+
+(defun m/d/y (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~2,,,'0 at A/~2,,,'0 at A/~2,,,'0 at A" month date (mod year 100))))
+
+(defun mm/dd (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~2,,,'0 at A/~2,,,'0 at A" month date)))
+
+(defun yyyy-mm-dd (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~4,,,'0 at A~2,,,'0 at A~2,,,'0 at A"
+ year month date)))
+
+(eval-now!
+ (export '(ymdhmsh)))
+
+(defun ymdhmsh (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~4,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A"
+ year month date hours minutes seconds (floor (* 10 (mod (now) 1.0))))))
+
+(defun hyphenated-time-string ()
+ (substitute #\- #\: (ymdhmsh)))
+
+#+test
+(hyphenated-time-string)
+
+#+test
+(ymdhmsh)
\ No newline at end of file
Added: dependencies/trunk/cells/utils-kt/debug.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/debug.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,150 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
+;;;
+#|
+
+ Utils-kt
+
+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)
+
+
+(defvar *count* nil)
+(defvar *counting* nil)
+(defvar *dbg*)
+(defvar *stop* nil)
+
+(defun utils-kt-reset ()
+ (clock-off :ukt-reset)
+ (setf *count* nil
+ *stop* nil
+ *dbg* nil)
+
+ (print "----------UTILSRESET----------------------------------"))
+
+;------------- counting ---------------------------
+
+(defmacro with-counts ((onp &rest msg) &body body)
+ `(if ,onp
+ (let ((*counting* (cons t *counting*)))
+ (prog2
+ (count-clear nil , at msg)
+ (progn , at body)
+ (show-count t , at msg)))
+ (progn , at body)))
+
+(defun count-of (key)
+ (cdr (assoc key *count* :key 'car)))
+
+(defun count-clear (announce &rest msg)
+ (declare (ignorable msg))
+ (when announce (format t "~&count-clear > ~a" msg))
+ (setf *count* nil))
+
+(defmacro count-it (&rest keys)
+ (declare (ignorable keys))
+ #+nahhh
+ `(progn)
+ `(when (car *counting*)
+ (call-count-it , at keys)))
+
+(export! count-it!)
+(defmacro count-it! (&rest keys)
+ (declare (ignorable keys))
+ #+(and its-alive! (not debugging-alive!))
+ `(progn)
+ #-(and its-alive! (not debugging-alive!))
+ `(when (car *counting*)
+ (call-count-it , at keys)))
+
+(defun call-count-it (&rest keys)
+ (declare (ignorable keys))
+ #+nahh (when (find (car keys) '(:trcfailed :TGTNILEVAL))
+ (break "clean up time ~a" keys))
+ (let ((entry (assoc keys *count* :test #'equal)))
+ (if entry
+ (setf (cdr entry) (1+ (cdr entry)))
+ (push (cons keys 1) *count*))))
+
+(defun show-count (clearp &rest msg &aux announced)
+
+ (let ((res (sort (copy-list *count*) (lambda (v1 v2)
+ (let ((v1$ (symbol-name (caar v1)))
+ (v2$ (symbol-name (caar v2))))
+ (if (string= v1$ v2$)
+ (< (cdr v1) (cdr v2))
+ (string< v1$ v2$))))))
+ )
+ (loop for entry in res
+ for occs = (cdr entry)
+ when (plusp occs)
+ sum occs into running
+ and do (unless announced
+ (setf announced t)
+ (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg))
+ (format t "~&~4d ... ~2d ... ~(~{~a ~}~)" running occs (car entry))))
+ (when clearp (count-clear announced "show-count" )))
+
+;-------------------- timex ---------------------------------
+
+(export! timex)
+
+(defmacro timex ((onp &rest trcargs) &body body)
+ `(if ,onp
+ (prog2
+ (format t "~&Starting timing run of ~{ ~a~}" (list , at trcargs))
+ (time (progn , at body))
+ (format t "~&Above timing was of ~{ ~a~}" (list , at trcargs)))
+ (progn , at body)))
+
+#+save
+(defun dbg-time-report (cpu-gc-user cpu-gc-sys cpu-tot-user cpu-tot-sys real-time conses other-bytes static-bytes)
+ (format t "~&cpu-gc-user ~a" cpu-gc-user)
+ (format t "~&cpu-gc-sys ~a" cpu-gc-sys)
+ (format t "~&cpu-tot-user ~a" cpu-tot-user)
+ (format t "~&cpu-tot-sys ~a" cpu-tot-sys)
+ (format t "~&<non-gc user cpu> ~a" (- cpu-tot-user cpu-gc-user))
+ (format t "~&<non-gc sys cpu> ~a" (- cpu-tot-sys cpu-gc-sys))
+ (format t "~&conses ~a" conses)
+ (format t "~&other-bytes ~a" other-bytes)
+ (format t "~&static-bytes ~a" static-bytes)
+ (excl::time-report cpu-gc-user cpu-gc-sys cpu-tot-user cpu-tot-sys real-time conses other-bytes static-bytes))
+
+;---------------- Metrics -------------------
+
+(defmacro with-metrics ((countp timep &rest trcargs) form-measured &body postlude)
+ `(with-counts (,countp , at trcargs)
+ (timex (,timep , at trcargs)
+ ,form-measured)
+ , at postlude))
+
+(defvar *clock*)
+
+(export! clock clock-0 clock-off)
+
+(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)))
+
Added: dependencies/trunk/cells/utils-kt/defpackage.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/defpackage.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,61 @@
+#|
+
+ Utils-kt
+
+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 :cl-user)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf *features* (remove :its-alive! *features*)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf *features* (pushnew :gimme-a-break *features*)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf *features* (remove :debugging-alive! *features*)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;;; #+(and its-alive! (not debugging-alive!))
+ ;;; (proclaim '(optimize (speed 3) (safety 1) (space 1) (debug 0)))
+ ;;; #-(and its-alive! (not debugging-alive!))
+ (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))))
+
+(defpackage :utils-kt
+ (:nicknames #:ukt)
+ (:use #:common-lisp
+ #+(or allegro lispworks clisp) #:clos
+ #+cmu #:mop
+ #+sbcl #:sb-mop
+ #+openmcl-partial-mop #:openmcl-mop
+ #+(and mcl (not openmcl-partial-mop)) #:ccl)
+ (:export
+ #:export!
+ #:utils-kt-reset
+ #:count-it #:count-of #:with-counts
+ #:wdbg #:maptimes #:bwhen #:bif #:xor
+ #:with-dynamic-fn #:last1 #:packed-flat! #:with-metrics
+ #:shortc
+ #:intern$
+ #:define-constant #:*count* #:*stop*
+ #:*dbg*
+ #:with-gensyms
+ #:make-fifo-queue #:fifo-queue #:fifo-add #:fifo-delete
+ #:fifo-empty #:fifo-pop #:fifo-clear
+ #:fifo-map #:fifo-peek #:fifo-data #:with-fifo-map #:fifo-length
+
+ #-(or lispworks mcl) #:true
+ #+(and mcl (not openmcl-partial-mop)) #:class-slots
+ ))
Added: dependencies/trunk/cells/utils-kt/detritus.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/detritus.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,230 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
+#|
+
+ Utils-kt
+
+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)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(eval-now! export! assocd rassoca class-proto brk)))
+
+(defmacro wdbg (&body body)
+ `(let ((*dbg* t))
+ , at body))
+
+(defun assocd (x y) (cdr (assoc x y)))
+(defun rassoca (x y) (car (assoc x y)))
+
+(defun class-proto (c)
+ (let ((cc (find-class c)))
+ (when cc
+ (finalize-inheritance cc))
+ (mop::class-prototype cc)))
+
+
+(defun brk (&rest args)
+ #+its-alive! (apply 'error args)
+ #-its-alive! (progn
+ ;;(setf *ctk-dbg* t)
+ (apply 'break args)))
+
+(defun find-after (x l)
+ (bIf (xm (member x l))
+ (cadr xm)
+ (brk "find-after ~a not member of ~a" x l)))
+
+(defun find-before (x l)
+ (loop with prior = nil
+ for i in l
+ if (eql i x)
+ return prior
+ else do (setf prior i)
+ finally (brk "find-before ~a not member of ~a" x l)))
+
+(defun list-insert-after (list after new )
+ (let* ((new-list (copy-list list))
+ (m (member after new-list)))
+ (rplacd m (cons new (cdr m)))
+ new-list))
+
+#+(and mcl (not openmcl-partial-mop))
+(defun class-slots (c)
+ (nconc (copy-list (class-class-slots c))
+ (copy-list (class-instance-slots c))))
+
+
+#-(or lispworks mcl)
+(progn
+ (defun true (it) (declare (ignore it)) t)
+ (defun false (it) (declare (ignore it))))
+
+(defun xor (c1 c2)
+ (if c1 (not c2) c2))
+
+(export! collect collect-if find-after find-before list-insert-after)
+
+(defun collect (x list &key (key 'identity) (test 'eql))
+ (loop for i in list
+ when (funcall test x (funcall key i))
+ collect i))
+
+(defun collect-if (test list)
+ (remove-if-not test list))
+
+;;; --- FIFO Queue -----------------------------
+
+(defun make-fifo-queue (&rest init-data)
+ (let ((q (cons nil nil)))
+ (prog1 q
+ (loop for id in init-data
+ do (fifo-add q id)))))
+
+(deftype fifo-queue () 'cons)
+
+(defun fifo-data (q) (car q))
+(defun fifo-clear (q) (rplaca q nil))
+(defun fifo-empty (q) (not (fifo-data q)))
+(defun fifo-length (q) (length (fifo-data q)))
+(defun fifo-peek (q) (car (fifo-data q)))
+
+(defun fifo-browse (q fn)
+ (map nil fn (fifo-data q)))
+
+(defun fifo-add (q new)
+ (if (car q)
+ (let ((last (cdr q))
+ (newlast (list new)))
+ (rplacd last newlast)
+ (rplacd q newlast))
+ (let ((newlist (list new)))
+ (rplaca q newlist)
+ (rplacd q newlist))))
+
+(defun fifo-delete (q dead)
+ (let ((c (member dead (fifo-data q))))
+ (assert c)
+ (rplaca q (delete dead (fifo-data q)))
+ (when (eq c (cdr q))
+ (rplacd q (last (fifo-data q))))))
+
+(defun fifo-pop (q)
+ (unless (fifo-empty q)
+ (prog1
+ (fifo-peek q)
+ (rplaca q (cdar q)))))
+
+(defun fifo-map (q fn)
+ (loop until (fifo-empty q)
+ do (funcall fn (fifo-pop q))))
+
+(defmacro with-fifo-map ((pop-var q) &body body)
+ (let ((qc (gensym)))
+ `(loop with ,qc = ,q
+ while (not (fifo-empty ,qc))
+ do (let ((,pop-var (fifo-pop ,qc)))
+ , at body))))
+
+#+(or)
+(let ((*print-circle* t))
+ (let ((q (make-fifo-queue)))
+ (loop for n below 3
+ do (fifo-add q n))
+ (fifo-delete q 1)
+ (loop until (fifo-empty q)
+ do (print (fifo-pop q)))))
+
+#+test
+(line-count "/openair" t 10 t)
+
+#+allegro
+(defun line-count (path &optional show-files (max-depth most-positive-fixnum) no-semis (depth 0))
+ (cond
+ ((excl:file-directory-p path)
+ (if (>= depth max-depth)
+ (progn
+ (format t "~&~v,8t~a dir too deep:" depth (pathname-directory path))
+ 0)
+ (progn
+ (when show-files
+ (format t "~&~v,8t~a counts:" depth (pathname-directory path)))
+ (let ((directory-lines
+ (loop for file in (directory path :directories-are-files nil)
+ for lines = (line-count file show-files max-depth no-semis (1+ depth))
+ when (and show-files (plusp lines))
+ do (bwhen (fname (pathname-name file))
+ (format t "~&~v,8t~a ~,40t~d" (1+ depth) fname lines))
+ summing 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")
+ :test 'string-equal)
+ (source-line-count path no-semis))
+ (t 0)))
+
+(defun source-line-count (path no-semis)
+ (with-open-file (s path)
+ (loop with block-rem = 0
+ for line = (read-line s nil nil)
+ for trim = (when line (string-trim '(#\space #\tab) line))
+ while line
+ when (> (length trim) 1)
+ do (cond
+ ((string= "#|" (subseq trim 0 2))(incf block-rem))
+ ((string= "|#" (subseq trim 0 2))(decf block-rem)))
+ unless (or (string= trim "")
+ (and no-semis (or (plusp block-rem)
+ (char= #\; (schar trim 0)))))
+ count 1)))
+
+#+(or)
+(line-count (make-pathname
+ :device "c"
+ :directory `(:absolute "0algcount" ))
+ nil 5 t)
+
+#+(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 "0Algebra" "1-devtools" ,d1))))
+
+
+(export! tree-includes tree-traverse tree-intersect)
+
+(defun tree-includes (sought tree &key (test 'eql))
+ (typecase tree
+ (null)
+ (atom (funcall test sought tree))
+ (cons (or (tree-includes sought (car tree) :test test)
+ (tree-includes sought (cdr tree) :test test)))))
+
+(defun tree-traverse (tree fn)
+ (typecase tree
+ (null)
+ (atom (funcall fn tree))
+ (cons (tree-traverse (car tree) fn)
+ (tree-traverse (cdr tree) fn)))
+ (values))
+
+(defun tree-intersect (t1 t2 &key (test 'eql))
+ (tree-traverse t1
+ (lambda (t1-node)
+ (when (tree-includes t1-node t2 :test test)
+ (return-from tree-intersect t1-node)))))
+
Added: dependencies/trunk/cells/utils-kt/flow-control.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/flow-control.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,254 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
+#|
+
+ Utils-kt
+
+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)
+
+(defun last1 (thing)
+ (car (last thing)))
+
+(defun max-if (&rest values)
+ (loop for x in values when x maximize x))
+
+(defun min-max-of (v1 v2)
+ (values (min-if v1 v2) (max-if v1 v2)))
+
+(defun min-if (v1 v2)
+ (if v1 (if v2 (min v1 v2) v1) v2))
+
+(export! list-flatten! tree-flatten list-insertf subseq-contiguous-p pair-off)
+
+(defun list-flatten! (&rest list)
+ (if (consp list)
+ (let (head work visited)
+ (labels ((link (cell)
+ ;;(format t "~&Link > cons: ~s . ~s" (car cell) (cdr cell))
+ (when (and (consp cell)
+ (member cell visited))
+ (break "list-flatten! detects infinite list: cell ~a, visited ~a" cell visited))
+ (push cell visited)
+
+ (when cell
+ (if (consp (car cell))
+ (link (car cell))
+ (progn
+ (setf head (or head cell))
+ (when work
+ (rplacd work cell))
+ (setf work cell)))
+ (link (rest cell)))))
+ (link list))
+ head)
+ list))
+
+(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)
+ do (let ((pair (find (car copy) (cdr copy) :test test)))
+ (if pair
+ (progn
+ (push-end (cons (car copy) pair) pairs)
+ (setf copy (delete pair (cdr copy) :count 1)))
+ (setf copy (cdr copy))))
+ finally (return pairs)))
+
+(defun packed-flat! (&rest u-nameit)
+ (delete nil (list-flatten! u-nameit)))
+
+(defmacro with-dynamic-fn ((fn-name (&rest fn-args) &body fn-body) &body body)
+ `(let ((,fn-name (lambda ,fn-args , at fn-body)))
+ (declare (dynamic-extent ,fn-name))
+ , at body))
+
+(defmacro list-insertf (place item &key after)
+ (let ((list (gensym))
+ (afterv (gensym))
+ (afters (gensym)))
+ `(let* ((,list ,place)
+ (,afterv ,after)
+ (,afters (when ,afterv (member ,after ,list))))
+ (assert (or (null ,afterv) ,afters) () "list-insertf after ~a not in list ~a" ,afterv ,list)
+ (setf ,place
+ (if ,afterv
+ (append (ldiff ,list ,afters)
+ (list ,afterv)
+ (list ,item)
+ (cdr ,afters))
+ (append ,list (list ,item)))))))
+
+(defun intern$ (&rest strings)
+ (intern (apply #'concatenate 'string strings)))
+
+#-allegro
+(defmacro until (test &body body)
+ `(loop (when ,test (return)) , at body))
+
+#-allegro
+(defmacro while (test &body body)
+ `(loop (unless ,test (return)) , at body))
+
+(defmacro bwhen ((bindvar boundform) &body body)
+ `(let ((,bindvar ,boundform))
+ (when ,bindvar
+ , at body)))
+
+(defmacro b-when (bindvar boundform &body body)
+ `(let ((,bindvar ,boundform))
+ (when ,bindvar
+ , at body)))
+
+(defmacro bif ((bindvar boundform) yup &optional nope)
+ `(let ((,bindvar ,boundform))
+ (if ,bindvar
+ ,yup
+ ,nope)))
+
+(defmacro b-if (bindvar boundform yup &optional nope)
+ `(let ((,bindvar ,boundform))
+ (if ,bindvar
+ ,yup
+ ,nope)))
+
+(defmacro b1 ((bindvar boundform) &body body)
+ `(let ((,bindvar ,boundform))
+ , at body))
+
+(defmacro maptimes ((nvar count) &body body)
+ `(loop for ,nvar below ,count
+ collecting (progn , at body)))
+
+(export! b1 maphash* hashtable-assoc -1?1 -1?1 prime? b-if b-when)
+
+(defun maphash* (f h)
+ (loop for k being the hash-keys of h
+ using (hash-value v)
+ collecting (funcall f k v)))
+
+(defun hashtable-assoc (h)
+ (maphash* (lambda (k v) (cons k v)) h))
+
+(define-symbol-macro -1?1 (expt -1 (random 2)))
+
+(defun -1?1 (x) (* -1?1 x))
+
+(defun prime? (n)
+ (when (> n 1)
+ (cond
+ ((= 2 n) t)
+ ((evenp n) (values nil 2))
+ (t (loop for d upfrom 3 by 2 to (sqrt n)
+ when (zerop (mod n d)) do (return-from prime? (values nil d))
+ finally (return t))))))
+
+
+
+; --- cloucell support for struct access of slots ------------------------
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+ (export '(cc-defstruct instance-slots)))
+
+(defmacro cc-defstruct (header &rest slots)
+ (let (name conc-name (cache (gensym)))
+ (if (consp header)
+ (destructuring-bind (hname &rest options)
+ header
+ (setf name hname)
+ (setf conc-name (bif (conc-option (find :conc-name options :key #'car))
+ (unless (eql (second conc-option) 'nil)
+ (second conc-option))
+ (intern (concatenate 'string
+ (symbol-name hname)
+ "-")))))
+ (progn
+ (setf name header)
+ (setf conc-name (intern (concatenate 'string
+ (symbol-name header) "-")))))
+
+ (let ((cc-info (mapcar (lambda (s)
+ (let ((sn (if (consp s)
+ (car s) s)))
+ (cons sn
+ (intern (concatenate 'string
+ (when conc-name (symbol-name conc-name))
+ (symbol-name sn))))))
+ slots)))
+ `(progn
+ (defstruct ,header , at slots)
+ (let (,cache)
+ (defmethod instance-slots ((self ,name))
+ (or ,cache (setf ,cache (append (call-next-method) ',cc-info)))))
+ ))))
+
+(defmethod instance-slots (self)
+ (class-slots (class-of self))) ;; acl has this for structs
+
+;;; ---- without-repeating ----------------------------------------------
+
+;; Returns a function that generates an elements from ALL each time it
+;; is called. When a certain element is generated it will take at
+;; least DECENT-INTERVAL calls before it is generated again.
+;;
+;; note: order of ALL is important for first few calls, could be fixed
+
+(defun without-repeating-generator (decent-interval all)
+ (let ((len (length all))
+ (head (let ((v (shuffle all)))
+ (nconc v v))))
+ (lambda ()
+ ;(print (list "without-repeating-generator sees len all =" len :decent-interval decent-interval))
+ (if (< len 2)
+ (car all)
+ (prog2
+ (rotatef (car head)
+ (car (nthcdr (random (- len decent-interval))
+ head)))
+ (car head)
+ (setf head (cdr head)))))))
+
+(defun shuffle (list &key (test 'identity))
+ (if (cdr list)
+ (loop thereis
+ (funcall test
+ (mapcar 'cdr
+ (sort (loop for e in list collecting (cons (random most-positive-fixnum) e))
+ '< :key 'car))))
+ (copy-list list)))
+
+(export! without-repeating shuffle)
+
+(defparameter *without-repeating-generators* nil)
+
+(defun reset-without-repeating ()
+ (if *without-repeating-generators*
+ (clrhash *without-repeating-generators*)
+ (setf *without-repeating-generators* (make-hash-table :test 'equalp))))
+
+(defun without-repeating (key all &optional (decent-interval (floor (length all) 2)))
+ (funcall (or (gethash key *without-repeating-generators*)
+ (progn
+ ;(print (list "without-repeating makes new gen" key :all-len (length all) :int decent-interval))
+ (setf (gethash key *without-repeating-generators*)
+ (without-repeating-generator decent-interval all))))))
+
Added: dependencies/trunk/cells/utils-kt/quad.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/quad.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,199 @@
+
+#|
+
+From: Erik Naggum (erik at naggum.no)
+Subject: Re: XML->sexpr ideas
+Newsgroups: comp.lang.lisp
+Date: 2004-01-19 04:24:43 PST
+
+* Kenny Tilton
+| Of course it is easy enough for me to come up with a sexpr format off
+| the top of my head, but I seem to recall someone (Erik? Tim? Other?)
+| saying they had done some work on a formal approach to an alternative
+| to XML/HTML/whatever.
+|
+| True that? If so, I am all ears.
+
+ Really? You are? Maybe I didn't survive 2003 and this is some Hell
+ where people have to do eternal penance, and now I get to do SGML all
+ over again.
+
+ Much processing of SGML-like data appears to be stream-like and will
+ therefore appear to be equivalent to an in-order traversal of a tree,
+ which can therefore be represented with cons cells while the traverser
+ maintains its own backward links elsewhere, but this is misleading.
+
+ The amount of work and memory required to maintain the proper backward
+ links and to make the right decisions is found in real applications to
+ balloon and to cause random hacks; the query languages reflect this
+ complexity. Ease of access to the parent element is crucial to the
+ decision-making process, so if one wants to use a simple list to keep
+ track of this, the most natural thing is to create a list of the
+ element type, the parent, and the contents, such that each element has
+ the form (type parent . contents), but this has the annoying property
+ that moving from a particular element to the next can only be done by
+ remembering the position of the current element in a list, just as one
+ cannot move to the next element in a list unless you keep the cons
+ cell around. However, the whole point of this exercise is to be able
+ to keep only one pointer around. So the contents of an element must
+ have the form (type parent contents . tail) if it has element contents
+ or simply a list of objects, or just the object if simple enough.
+
+ Example: <foo>123</foo> would thus be represented by (foo nil "123"),
+ <foo>123</foo><bar>456</bar> by (foo nil "123" bar nil "456"), and
+ <zot><foo>123</foo><bar>456</bar></zot> by #1=(zot nil (foo #1# "123"
+ bar #1# "456")).
+
+ Navigation inside this kind of structure is easy: When the contents in
+ CADDR is exhausted, the CDDDR is the next element, or if NIL, we have
+ exhausted the contents of the parent and move up to the CADR and look
+ for its next element, etc. All the important edges of the containers
+ that make up the *ML document are easily detectible and the operations
+ that are usually found at the edges are normally tied to the element
+ type (or as modified by its parents), are easily computable. However,
+ using a list for this is cumbersome, so I cooked up the «quad». The
+ «quad» is devoid of any intrinsic meaning because it is intended to be
+ a general data structure, so I looked for the best meaningless names
+ for the slots/accessors, and decided on QAR, QBR, QCR, and QDR. The
+ quad points to the element type (like the operator in a sexpr) in the
+ QAR, the parent (or back) quad in the QBR, the contents of the element
+ in the QCR, and the usual pointer to the next quad in the QDR.
+
+ Since the intent with this model is to «load» SGML/XML/SALT documents
+ into memory, one important issue is how to represent long stretches of
+ character content or binary content. The quad can easily be used to
+ represent a (sequence of) entity fragments, with the source in QAR,
+ the start position in QBR, and the end position in QCR, thereby using
+ a minimum of memory for the contents. Since very large documents are
+ intended to be loaded into memory, this property is central to the
+ ability to search only selected elements for their contents -- most
+ searching processors today parse the entire entity structure and do
+ very little to maintain the parsed element structure.
+
+ Speaking of memory, one simple and efficient way to implement the quad
+ on systems that lack the ability to add native types without overhead,
+ is to use a two-dimensional array with a second dimension of 4 and let
+ quad pointers be integers, which is friendly to garbage collection and
+ is unambiguous when the quad is used in the way explained above.
+
+ Maybe I'll talk about SALT some other day.
+
+--
+Erik Naggum | Oslo, Norway
+
+Act from reason, and failure makes you rethink and study harder.
+Act from faith, and failure makes you blame someone and push harder.
+
+|#
+
+(in-package :ukt)
+
+;;;(defstruct (juad jar jbr jcr jdr)
+
+
+
+(defun qar (q) (car q))
+(defun (setf qar) (v q) (setf (car q) v))
+
+(defun qbr (q) (cadr q))
+(defun (setf qbr) (v q) (setf (cadr q) v))
+
+(defun qcr (q) (caddr q))
+(defun (setf qcr) (v q) (setf (caddr q) v))
+
+(defun qdr (q) (cdddr q))
+(defun (setf qdr) (v q) (setf (cdddr q) v))
+
+(defun sub-quads (q)
+ (loop for childq on (qcr q) by #'qdr
+ collecting childq))
+
+(defun sub-quads-do (q fn)
+ (loop for childq on (qcr q) by #'qdr
+ do (funcall fn childq)))
+
+(defun quad-traverse (q fn &optional (depth 0))
+ (funcall fn q depth)
+ (sub-quads-do q
+ (lambda (subq)
+ (quad-traverse subq fn (1+ depth)))))
+
+(defun quad (operator parent contents next)
+ (list operator parent contents next))
+
+(defun quad* (operator parent contents next)
+ (list operator parent contents next))
+
+(defun qups (q)
+ (loop for up = (qbr q) then (qbr up)
+ unless up do (loop-finish)
+ collecting up))
+
+(defun quad-tree (q)
+ (list* (qar q)
+ (loop for childq on (qcr q) by #'qdr
+ while childq
+ collecting (quad-tree childq))))
+
+(defun tree-quad (tree &optional parent)
+ (let* ((q (quad (car tree) parent nil nil))
+ (kids (loop for k in (cdr tree)
+ collecting (tree-quad k q))))
+ (loop for (k n) on kids
+ do (setf (qdr k) n))
+ (setf (qcr q) (car kids))
+ q))
+
+#+test
+(test-qt)
+
+(defun test-qt ()
+ (print (quad-tree #1='(zot nil (foo #1# ("123" "abc")
+ . #2=(bar #1# (ding #2# "456"
+ dong #2# "789")))))))
+
+(print #1='(zot nil (foo #1# ("123" "abc")
+ . #2=(bar #1# (ding #2# "456"
+ dong #2# "789")))))
+#+xxxx
+(test-tq)
+
+(defun test-tq ()
+ (let ((*print-circle* t)
+ (tree '(zot (foo ("123")) (bar (ding) (dong)))))
+ (assert (equal tree (quad-tree (tree-quad tree))))))
+
+(defun testq ()
+ (let ((*print-circle* t))
+ (let ((q #1='(zot nil (foo #1# ("123" "abc")
+ . #2=(bar #1# (ding #2# "456"
+ dong #2# "789"))))))
+ (print '(traverse showing each type and data preceded by its depth))
+
+ (quad-traverse q (lambda (q depth)
+ (print (list depth (qar q)(qcr q)))))
+ (print `(listify same ,(quad-tree q))))
+ (let ((q #2='(zot nil (ding #2# "456"
+ dong #2# "789"))))
+ (print '(traverse showing each "car" and itd parentage preceded by its depth))
+ (print '(of data (zot (ding (dong)))))
+ (quad-traverse q (lambda (q depth)
+ (print (list depth (qar q)
+ (mapcar 'qar (qups q)))))))))
+
+;;;(defun tree-quad (tree)
+
+
+(defun testq2 ()
+ (let ((*print-circle* t))
+ (let ((q #2='(zot nil (ding #2# "456"
+ dong #2# "789"))))
+ (print '(traverse showing each "car" and itd parentage preceded by its depth))
+ (print '(of data (zot (ding (dong)))))
+ (quad-traverse q (lambda (q depth)
+ (print (list depth (qar q)
+ (mapcar 'qar (qups q)))))))))
+
+
+
+
\ No newline at end of file
Added: dependencies/trunk/cells/utils-kt/split-sequence.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/split-sequence.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,223 @@
+;;;; SPLIT-SEQUENCE
+;;;
+;;; This code was based on Arthur Lemmens' in
+;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>;
+;;;
+;;; changes include:
+;;;
+;;; * altering the behaviour of the :from-end keyword argument to
+;;; return the subsequences in original order, for consistency with
+;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only
+;;; affects the answer if :count is less than the number of
+;;; subsequences, by analogy with the above-referenced functions).
+;;;
+;;; * changing the :maximum keyword argument to :count, by analogy
+;;; with CL:REMOVE, CL:SUBSTITUTE, and so on.
+;;;
+;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather
+;;; than SPLIT.
+;;;
+;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT.
+;;;
+;;; * The second return value is now an index rather than a copy of a
+;;; portion of the sequence; this index is the `right' one to feed to
+;;; CL:SUBSEQ for continued processing.
+
+;;; There's a certain amount of code duplication here, which is kept
+;;; to illustrate the relationship between the SPLIT-SEQUENCE
+;;; functions and the CL:POSITION functions.
+
+;;; Examples:
+;;;
+;;; * (split-sequence #\; "a;;b;c")
+;;; -> ("a" "" "b" "c"), 6
+;;;
+;;; * (split-sequence #\; "a;;b;c" :from-end t)
+;;; -> ("a" "" "b" "c"), 0
+;;;
+;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1)
+;;; -> ("c"), 4
+;;;
+;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t)
+;;; -> ("a" "b" "c"), 6
+;;;
+;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra")
+;;; -> ("" "" "r" "c" "d" "" "r" ""), 11
+;;;
+;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra")
+;;; -> ("ab" "a" "a" "ab" "a"), 11
+;;;
+;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9)
+;;; -> ("oo" "bar" "b"), 9
+
+;; cl-utilities note: the license of this file is unclear, and I don't
+;; even know whom to contact to clarify it. If anybody objects to my
+;; assumption that it is public domain, please contact me so I can do
+;; something about it. Previously I required the split-sequence
+ ; package as a dependency, but that was so unwieldy that it was *the*
+;; sore spot sticking out in the design of cl-utilities. -Peter Scott
+
+(in-package :utils-kt)
+
+(export! split-sequence)
+
+(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil)
+ (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by delimiter.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE. In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+ (let ((len (length seq))
+ (other-keys (nconc (when test-supplied
+ (list :test test))
+ (when test-not-supplied
+ (list :test-not test-not))
+ (when key-supplied
+ (list :key key)))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position delimiter seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position delimiter seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by items satisfying
+predicate.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE-IF. In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+ (let ((len (length seq))
+ (other-keys (when key-supplied
+ (list :key key))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position-if predicate seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position-if predicate seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by items satisfying
+(CL:COMPLEMENT predicate).
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular,
+the behaviour of :from-end is possibly different from other versions
+of this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped." ; Emacs syntax highlighting is broken, and this helps: "
+ (let ((len (length seq))
+ (other-keys (when key-supplied
+ (list :key key))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position-if-not predicate seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position-if-not predicate seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+
+
+(pushnew :split-sequence *features*)
Added: dependencies/trunk/cells/utils-kt/strings.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/strings.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,221 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
+#|
+
+ Utils-kt
+
+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)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(case$ strloc$ make$ space$ char$ conc-list$ conc$
+ left$ mid$ seg$ right$ insert$ remove$
+ trim$ trunc$ abbrev$ empty$ find$ num$
+ normalize$ down$ lower$ up$ upper$ equal$
+ min$ numeric$ alpha$ assoc$ member$ starts$
+ +return$+ +lf$+ case-string-equal)))
+
+(defmacro case$ (string-form &rest cases)
+ (let ((v$ (gensym))
+ (default (or (find 'otherwise cases :key #'car)
+ (find 'otherwise cases :key #'car))))
+ (when default
+ (setf cases (delete default cases)))
+ `(let ((,v$ ,string-form))
+ (cond
+ ,@(mapcar (lambda (case-forms)
+ `((string-equal ,v$ ,(car case-forms)) ,@(rest case-forms)))
+ cases)
+ (t ,@(or (cdr default) `(nil)))))))
+
+(defmacro case-string-equal (string-form &rest cases)
+ (let ((v$ (gensym))
+ (default (or (find 'otherwise cases :key #'car)
+ (find 'otherwise cases :key #'car))))
+ (when default
+ (setf cases (delete default cases)))
+ `(let ((,v$ ,string-form))
+ (cond
+ ,@(mapcar (lambda (case-forms)
+ `((string-equal ,v$ ,(string (car case-forms))) ,@(rest case-forms)))
+ cases)
+ (t ,@(or (cdr default) `(nil)))))))
+
+;--------
+
+(defmethod shortc (other)
+ (declare (ignorable other))
+ (concatenate 'string "noshortc" (symbol-name (class-name (class-of other)))))
+
+(defmethod longc (other) (shortc other))
+
+(defmethod shortc ((nada null)) nil)
+(defmethod shortc ((many list))
+ (if (consp (cdr many))
+ (mapcar #'shortc many)
+ (conc$ (shortc (car many)) " " (shortc (cdr many)))))
+(defmethod shortc ((self string)) self)
+(defmethod shortc ((self symbol)) (string self))
+(defmethod shortc ((self number)) (num$ self))
+(defmethod shortc ((self character)) (string self))
+
+;-----------------------
+
+(defun strloc$ (substr str)
+ (when (and substr str (not (string= substr "")))
+ (search substr str)))
+
+(defun make$ (&optional (size 0) (char #\space))
+ (make-string size :initial-element (etypecase char
+ (character char)
+ (number (code-char char)))))
+(defun basic$ ()
+ (make-array 0 :element-type 'character :adjustable t :fill-pointer 0))
+
+(defun space$ (size)
+ (make$ size))
+
+(defun char$ (char)
+ (make$ 1 char))
+
+(defun conc-list$ (ss)
+ (when ss
+ (reduce (lambda (s1 s2) (concatenate 'string s1 s2)) ss)))
+
+(defun conc$ (&rest ss)
+ (with-output-to-string (stream)
+ (dolist (s ss)
+ (when s
+ (princ (shortc s) stream)))))
+
+(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)))
+ (end (max start (min (+ offset length) slen))))
+ (subseq s start end)))
+
+(defun seg$ (s offset end)
+ (let* ((slen (length s))
+ (start (min slen (max offset 0)))
+ (end (max start (min end slen))))
+ (subseq s start end)))
+
+(defun right$ (s n)
+ (subseq s (min n (length s))))
+
+(defun insert$ (s c &optional (offset (length s)))
+ (conc$ (subseq s 0 offset)
+ (string c)
+ (subseq s offset)))
+
+(defun remove$ (s offset)
+ (conc$ (subseq s 0 (1- offset))
+ (subseq s offset)))
+
+(defun trim$ (s)
+ (assert (or (null s) (stringp s)))
+ (string-trim '(#\space) s))
+
+(defun trunc$ (s char)
+ (let ((pos (position char s)))
+ (if pos
+ (subseq s 0 pos)
+ s)))
+
+(defun abbrev$ (long$ max)
+ (if (<= (length long$) max)
+ long$
+ (conc$ (left$ long$ (- max 3)) "...")))
+
+(defmethod empty ((nada null)) t)
+(defmethod empty ((c cons))
+ (and (empty (car c))
+ (empty (cdr c))))
+(defmethod empty ((s string)) (empty$ s))
+(defmethod empty (other) (declare (ignorable other)) nil)
+
+(defun empty$ (s)
+ (or (null s)
+ (if (stringp s)
+ (string-equal "" (trim$ s))
+ #+(or) (format t "empty$> sees non-string ~a" (type-of s)))))
+
+(defmacro find$ (it where &rest args)
+ `(find ,it ,where , at args :test #'string-equal))
+
+(defmethod num$ ((n number))
+ (format nil "~d" n))
+
+(defmethod num$ (n)
+ (format nil "~d" n))
+
+(defun normalize$ (s)
+ (down$ s))
+
+(defun down$ (s)
+ (etypecase s
+ (null "")
+ (string (string-downcase s))
+ (number (format nil "~a" s))
+ (symbol (string-downcase (symbol-name s)))
+ (cons (format nil "~{~(~a~)~^ ~}" s))))
+
+(defun lower$ (s)
+ (string-downcase s))
+
+(defun up$ (s)
+ (string-upcase s))
+
+(defun upper$ (s)
+ (string-upcase s))
+
+(defun equal$ (s1 s2)
+ (if (empty$ s1)
+ (empty$ s2)
+ (when s2
+ (string-equal s1 s2))))
+
+(defun min$ (&rest ss)
+ (cond
+ ((null ss) nil)
+ ((null (cdr ss)) (car ss))
+ (t (let ((rmin$ (apply #'min$ (cdr ss))))
+ (if (string< (car ss) rmin$)
+ (car ss) rmin$)))))
+
+(defun numeric$ (s &optional trimmed)
+ (every (lambda (c) (digit-char-p c)) (if trimmed (trim$ s) s)))
+
+(defun alpha$ (s)
+ (every (lambda (c) (alpha-char-p c)) s))
+
+(defmacro assoc$ (item alist &rest kws)
+ `(assoc ,item ,alist :test #'equal , at kws))
+
+(defmacro member$ (item list &rest kws)
+ `(member ,item ,list :test #'string= , at kws))
+
+(defun starts$ (a b)
+ (bwhen (s (search b a))
+ (zerop s)))
+
+(defparameter *return$* (conc$ (char$ #\return) (char$ #\linefeed)))
+(defparameter *lf$* (string #\linefeed))
Added: dependencies/trunk/cells/utils-kt/utils-kt.asd
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/utils-kt.asd Tue Jan 26 15:20:07 2010
@@ -0,0 +1,30 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+
+;(declaim (optimize (debug 2) (speed 1) (safety 1) (compilation-speed 1)))
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+
+;;;(operate 'load-op :asdf-aclproj)
+;;;(use-package :asdf-aclproj)
+
+#+(or allegro lispworks cmu mcl clisp cormanlisp sbcl scl abcl)
+
+(asdf:defsystem :utils-kt
+ :name "utils-kt"
+ :author "Kenny Tilton <ktilton at nyc.rr.com>"
+ :version "2007-12-02"
+ :maintainer "Kenny Tilton <ktilton at nyc.rr.com>"
+ :licence "MIT Style"
+ :description "Kenny's Utilities"
+ :long-description "Low-level utilities used by all of Kenny's projects"
+ :components ((:file "defpackage")
+ (:file "core" :depends-on ("defpackage"))
+ (:file "debug" :depends-on ("core"))
+ (:file "flow-control" :depends-on ("core" "debug"))
+ (:file "detritus" :depends-on ("core" "debug"))
+ (:file "strings" :depends-on ("core" "debug"))
+ (:file "datetime" :depends-on ("core" "debug"))
+ (:file "split-sequence" :depends-on ("core" "debug"))))
+
+(defmethod perform ((o load-op) (c (eql (find-system :utils-kt))))
+ ; (pushnew "CELLS" *modules* :test #'string=)
+ (pushnew :utils-kt *features*))
Added: dependencies/trunk/cells/utils-kt/utils-kt.lpr
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/utils-kt.lpr Tue Jan 26 15:20:07 2010
@@ -0,0 +1,39 @@
+;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*-
+
+(in-package :cg-user)
+
+(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")
+ (make-instance 'module :name "strings.lisp")
+ (make-instance 'module :name "datetime.lisp")
+ (make-instance 'module :name "split-sequence.lisp"))
+ :projects nil
+ :libraries nil
+ :distributed-files nil
+ :internally-loaded-files nil
+ :project-package-name :common-lisp
+ :main-form nil
+ :compilation-unit t
+ :verbose nil
+ :runtime-modules nil
+ :splash-file-module (make-instance 'build-module :name "")
+ :icon-file-module (make-instance 'build-module :name "")
+ :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 (list :read-init-files nil)
+ :old-space-size 256000
+ :new-space-size 6144
+ :runtime-build-option :standard
+ :build-number 0
+ :on-initialization 'default-init-function
+ :on-restart 'do-default-restart)
+
+;; End of Project Definition
Added: dependencies/trunk/cells/variables.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/variables.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,118 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+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 :cells)
+
+(defun c-variable-accessor (symbol)
+ (assert (symbolp symbol))
+ (c-variable-reader symbol))
+
+(defun (setf c-variable-accessor) (value symbol)
+ (assert (symbolp symbol))
+ (c-variable-writer value symbol))
+
+(defun c-variable-reader (symbol)
+ (assert (symbolp symbol))
+ (assert (get symbol 'cell))
+ (cell-read (get symbol 'cell)))
+
+(defun c-variable-writer (value symbol)
+ (assert (symbolp symbol))
+ (setf (md-slot-value nil symbol) value)
+ (setf (symbol-value symbol) value))
+
+(export! def-c-variable)
+
+(defmacro def-c-variable (v-name cell &key ephemeral owning unchanged-if)
+ (declare (ignore unchanged-if))
+ (let ((c 'whathef)) ;;(gensym)))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel)
+ (define-symbol-macro ,v-name (c-variable-accessor ',v-name))
+ (setf (md-slot-cell-type 'null ',v-name) (when ,ephemeral :ephemeral))
+ (when ,owning
+ (setf (md-slot-owning 'null ',v-name) t)))
+ (eval-when (:load-toplevel)
+ (let ((,c ,cell))
+ (md-install-cell nil ',v-name ,c)
+ (awaken-cell ,c)))
+ ',v-name)))
+
+
+(defobserver *kenny* ()
+ (trcx kenny-obs new-value old-value old-value-boundp))
+
+#+test
+(def-c-variable *kenny* (c-in nil))
+
+
+#+test
+(defmd kenny-watcher ()
+ (twice (c? (bwhen (k *kenny*)
+ (* 2 k)))))
+
+(defobserver twice ()
+ (trc "twice kenny is:" new-value self old-value old-value-boundp))
+
+#+test-ephem
+(progn
+ (cells-reset)
+ (let ((tvw (make-instance 'kenny-watcher)))
+ (trcx twice-read (twice tvw))
+ (setf *c-debug* nil)
+ (setf *kenny* 42)
+ (setf *kenny* 42)
+ (trcx post-setf-kenny *kenny*)
+ (trcx print-twice (twice tvw))
+ ))
+
+#+test
+(let ((*kenny* 13)) (print *kenny*))
+
+#+test
+(let ((c (c-in 42)))
+ (md-install-cell '*test-c-variable* '*test-c-variable* c)
+ (awaken-cell c)
+ (let ((tvw (make-instance 'test-var-watcher)))
+ (trcx twice-read (twice tvw))
+ (setf *test-c-variable* 69)
+ (trcx print-testvar *test-c-variable*)
+ (trcx print-twice (twice tvw))
+ (unless (eql (twice tvw) 138)
+ (inspect (md-slot-cell tvw 'twice))
+ (inspect c)
+ ))
+ )
+
+#+test2
+(let ((tvw (make-instance 'test-var-watcher :twice (c-in 42))))
+ (let ((c (c? (trcx joggggggggging!!!!!!!!!!!!!!!)
+ (floor (twice tvw) 2))))
+ (md-install-cell '*test-c-variable* '*test-c-variable* c)
+ (awaken-cell c)
+ (trcx print-testvar *test-c-variable*)
+ (trcx twice-read (twice tvw))
+ (setf (twice tvw) 138)
+ (trcx print-twice (twice tvw))
+ (trcx print-testvar *test-c-variable*)
+ (unless (eql *test-c-variable* 69)
+ (inspect (md-slot-cell tvw 'twice))
+ (inspect c)
+ ))
+ )
+
Added: dependencies/trunk/cl-utilities-1.2.4/README
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/README Tue Jan 26 15:20:07 2010
@@ -0,0 +1,59 @@
+CL-UTILITIES Collection
+=======================
+
+On Cliki.net <http://www.cliki.net/Common%20Lisp%20Utilities>, there
+is a collection of Common Lisp Utilities, things that everybody writes
+since they're not part of the official standard. There are some very
+useful things there; the only problems are that they aren't
+implemented as well as you'd like (some aren't implemented at all) and
+they aren't conveniently packaged and maintained. It takes quite a bit
+of work to carefully implement utilities for common use, commented
+and documented, with error checking placed everywhere some dumb user
+might make a mistake.
+
+The CLRFI process <http://clrfi.alu.org/> is a lot better thought out,
+and will probably produce better standards than informal discussion on
+a Wiki, but it has one problem: at the time of this writing, it's not
+doing anything yet. Until the CLRFI process gets going, I think that a
+high-quality collection of the informal standards on Cliki is a
+valuable thing to have. It's here, and it's called cl-utilities.
+
+The home page is <http://common-lisp.net/project/cl-utilities/>.
+
+Documentation
+-------------
+
+Right now, documentation is at
+<http://www.cliki.net/Common%20Lisp%20Utilities>. There are a few
+differences, though:
+
+* The READ-DELIMITED function takes :start and :end keyword args.
+* A WITH-GENSYMS function is provided for compatibility.
+* COPY-ARRAY is not called SHALLOW-COPY-ARRAY.
+* The ONCE-ONLY macro is included.
+
+Installation
+------------
+
+To install cl-utilities, you'll need to do one of two things:
+
+* Download cl-utilities into a place where asdf can find it, then
+ load it via asdf. You will also need to get the split-sequence
+ package, which cl-utilities depends on.
+
+-or-
+
+* Use asdf-install: (asdf-install:install :cl-utilities)
+
+Feedback
+--------
+
+The current maintainer is Peter Scott. If you have questions, bugs,
+comments, or contributions, please send them to the cl-utilities-devel
+mailing list, <cl-utilities-devel at common-lisp.net>.
+
+License
+-------
+
+The code in cl-utilities is in the public domain. Do whatever you want
+with it.
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/cl-utilities.asd
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/cl-utilities.asd Tue Jan 26 15:20:07 2010
@@ -0,0 +1,33 @@
+;; -*- Lisp -*-
+
+(defpackage #:cl-utilities-system
+ (:use #:common-lisp #:asdf))
+
+(in-package #:cl-utilities-system)
+
+(defsystem cl-utilities
+ :author "Maintained by Peter Scott"
+ :components ((:file "package")
+ (:file "split-sequence" :depends-on ("package"))
+ (:file "extremum" :depends-on ("package"
+ "with-unique-names"
+ "once-only"))
+ (:file "read-delimited" :depends-on ("package"))
+ (:file "expt-mod" :depends-on ("package"))
+ (:file "with-unique-names" :depends-on ("package"))
+ (:file "collecting" :depends-on ("package"
+ "with-unique-names"
+ "compose"))
+ (:file "once-only" :depends-on ("package"))
+ (:file "rotate-byte" :depends-on ("package"))
+ (:file "copy-array" :depends-on ("package"))
+ (:file "compose" :depends-on ("package"))))
+
+;; Sometimes we can accelerate byte rotation on SBCL by using the
+;; SB-ROTATE-BYTE extension. This loads it.
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (handler-case (progn
+ (require :sb-rotate-byte)
+ (pushnew :sbcl-uses-sb-rotate-byte *features*))
+ (error () (delete :sbcl-uses-sb-rotate-byte *features*))))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/collecting.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/collecting.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,84 @@
+;; Opinions differ on how a collection macro should work. There are
+;; two major points for discussion: multiple collection variables and
+;; implementation method.
+;;
+;; There are two main ways of implementing collection: sticking
+;; successive elements onto the end of the list with tail-collection,
+;; and using the PUSH/NREVERSE idiom. Tail-collection is usually
+;; faster, except on CLISP, where PUSH/NREVERSE is a little faster.
+;;
+;; The COLLECTING macro only allows collection into one list, and you
+;; can't nest them to get the same effect as multiple collection since
+;; it always uses the COLLECT function. If you want to collect into
+;; multiple lists, use the WITH-COLLECT macro.
+
+(in-package :cl-utilities)
+
+;; This should only be called inside of COLLECTING macros, but we
+;; define it here to provide an informative error message and to make
+;; it easier for SLIME (et al.) to get documentation for the COLLECT
+;; function when it's used in the COLLECTING macro.
+(defun collect (thing)
+ "Collect THING in the context established by the COLLECTING macro"
+ (error "Can't collect ~S outside the context of the COLLECTING macro"
+ thing))
+
+(defmacro collecting (&body body)
+ "Collect things into a list forwards. Within the body of this macro,
+the COLLECT function will collect its argument into the list returned
+by COLLECTING."
+ (with-unique-names (collector tail)
+ `(let (,collector ,tail)
+ (labels ((collect (thing)
+ (if ,collector
+ (setf (cdr ,tail)
+ (setf ,tail (list thing)))
+ (setf ,collector
+ (setf ,tail (list thing))))))
+ , at body)
+ ,collector)))
+
+(defmacro with-collectors ((&rest collectors) &body body)
+ "Collect some things into lists forwards. The names in COLLECTORS
+are defined as local functions which each collect into a separate
+list. Returns as many values as there are collectors, in the order
+they were given."
+ (%with-collectors-check-collectors collectors)
+ (let ((gensyms-alist (%with-collectors-gensyms-alist collectors)))
+ `(let ,(loop for collector in collectors
+ for tail = (cdr (assoc collector gensyms-alist))
+ nconc (list collector tail))
+ (labels ,(loop for collector in collectors
+ for tail = (cdr (assoc collector gensyms-alist))
+ collect `(,collector (thing)
+ (if ,collector
+ (setf (cdr ,tail)
+ (setf ,tail (list thing)))
+ (setf ,collector
+ (setf ,tail (list thing))))))
+ , at body)
+ (values , at collectors))))
+
+(defun %with-collectors-check-collectors (collectors)
+ "Check that all of the COLLECTORS are symbols. If not, raise an error."
+ (let ((bad-collector (find-if-not #'symbolp collectors)))
+ (when bad-collector
+ (error 'type-error
+ :datum bad-collector
+ :expected-type 'symbol))))
+
+(defun %with-collectors-gensyms-alist (collectors)
+ "Return an alist mapping the symbols in COLLECTORS to gensyms"
+ (mapcar #'cons collectors
+ (mapcar (compose #'gensym
+ #'(lambda (x)
+ (format nil "~A-TAIL-" x)))
+ collectors)))
+
+;; Some test code which would be too hard to move to the test suite.
+#+nil (with-collectors (one-through-nine abc)
+ (mapcar #'abc '(a b c))
+ (dotimes (x 10)
+ (one-through-nine x)
+ (print one-through-nine))
+ (terpri) (terpri))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/compose.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/compose.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,51 @@
+;; This version of COMPOSE can only handle functions which take one
+;; value and return one value. There are other ways of writing
+;; COMPOSE, but this is the most commonly used.
+
+(in-package :cl-utilities)
+
+;; This is really slow and conses a lot. Fortunately we can speed it
+;; up immensely with a compiler macro.
+(defun compose (&rest functions)
+ "Compose FUNCTIONS right-associatively, returning a function"
+ #'(lambda (x)
+ (reduce #'funcall functions
+ :initial-value x
+ :from-end t)))
+
+;; Here's some benchmarking code that compares various methods of
+;; doing the same thing. If the first method, using COMPOSE, is
+;; notably slower than the rest, the compiler macro probably isn't
+;; being run.
+#+nil
+(labels ((2* (x) (* 2 x)))
+ (macrolet ((repeat ((x) &body body)
+ (with-unique-names (counter)
+ `(dotimes (,counter ,x)
+ (declare (type (integer 0 ,x) ,counter)
+ (ignorable ,counter))
+ , at body))))
+ ;; Make sure the compiler macro gets run
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (time (repeat (30000000) (funcall (compose #'1+ #'2* #'1+) 6)))
+ (time (repeat (30000000) (funcall (lambda (x) (1+ (2* (1+ x)))) 6)))
+ (time (repeat (30000000)
+ (funcall (lambda (x)
+ (funcall #'1+ (funcall #'2* (funcall #'1+ x))))
+ 6)))))
+
+;; Converts calls to COMPOSE to lambda forms with everything written
+;; out and some things written as direct function calls.
+;; Example: (compose #'1+ #'2* #'1+) => (LAMBDA (X) (1+ (2* (1+ X))))
+(define-compiler-macro compose (&rest functions)
+ (labels ((sharp-quoted-p (x)
+ (and (listp x)
+ (eql (first x) 'function)
+ (symbolp (second x)))))
+ `(lambda (x) ,(reduce #'(lambda (fun arg)
+ (if (sharp-quoted-p fun)
+ (list (second fun) arg)
+ (list 'funcall fun arg)))
+ functions
+ :initial-value 'x
+ :from-end t))))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/copy-array.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/copy-array.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,29 @@
+(in-package :cl-utilities)
+
+(defun copy-array (array &key (undisplace nil))
+ "Shallow copies the contents of any array into another array with
+equivalent properties. If array is displaced, then this function will
+normally create another displaced array with similar properties,
+unless UNDISPLACE is non-NIL, in which case the contents of the array
+will be copied into a completely new, not displaced, array."
+ (declare (type array array))
+ (let ((copy (%make-array-with-same-properties array undisplace)))
+ (unless (array-displacement copy)
+ (dotimes (n (array-total-size copy))
+ (setf (row-major-aref copy n) (row-major-aref array n))))
+ copy))
+
+(defun %make-array-with-same-properties (array undisplace)
+ "Make an array with the same properties (size, adjustability, etc.)
+as another array, optionally undisplacing the array."
+ (apply #'make-array
+ (list* (array-dimensions array)
+ :element-type (array-element-type array)
+ :adjustable (adjustable-array-p array)
+ :fill-pointer (when (array-has-fill-pointer-p array)
+ (fill-pointer array))
+ (multiple-value-bind (displacement offset)
+ (array-displacement array)
+ (when (and displacement (not undisplace))
+ (list :displaced-to displacement
+ :displaced-index-offset offset))))))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/doc/collecting.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/doc/collecting.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,78 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Macro COLLECTING, WITH-COLLECTORS</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Macro</i> <b>COLLECTING</b></a></a> <p>
+<p><b>Syntax:</b><p>
+
+<p>
+
+<p><b>collecting</b> <i>form*</i> => <i>result</i><p>
+
+<p><b>with-collectors</b> <i>(collector*) form*</i> => <i>result</i>*<p>
+<p>
+<p><b>Arguments and Values:</b><p>
+<p>
+<i>forms</i>---an <a
+href="http://www.lispworks.com/documentation/HyperSpec/Body/glo_i.html#implicit_progn">implicit
+progn</a>.
+
+<p><i>collector</i>---a symbol which will have a collection function bound to it.
+
+<p><i>result</i>---a collected list.
+
+<p>
+<p><b>Description:</b><p>
+<p>
+<b>collecting</b> collects things into a list. Within the
+body of this macro, the <b>collect</b> function will collect its
+argument into <i>result</i>.
+
+<p><b>with-collectors</b> collects some things into lists. The
+<i>collector</i> names are defined as local functions which each
+collect into a separate list. Returns as many values as there are
+collectors, in the order they were given.
+
+<p><b>Exceptional situations:</b><p>
+<p>
+
+<p>If the <i>collector</i> names are not all symbols, a
+<b>type-error</b> will be signalled.
+
+<p><b>Examples:</b>
+
+<pre>
+(collecting (dotimes (x 10) (collect x))) => (0 1 2 3 4 5 6 7 8 9)
+
+(multiple-value-bind (a b)
+ (with-collectors (x y)
+ (x 1)
+ (y 2)
+ (x 3))
+ (append a b)) => (1 2 3)
+</pre>
+
+<p><p><b>Implementation notes:</b></p>
+
+<p>Opinions differ on how a collection macro should work. There are
+two major points for discussion: multiple collection variables and
+implementation method.</b>
+
+<p>There are two main ways of implementing collection: sticking
+successive elements onto the end of the list with tail-collection, or
+using the PUSH/NREVERSE idiom. Tail-collection is usually faster,
+except on CLISP, where PUSH/NREVERSE is a little faster because it's
+implemented in C which is always faster than Lisp bytecode.</p>
+
+<p>The <b>collecting</b> macro only allows collection into one list,
+and you can't nest them to get the same effect as multiple collection
+since it always uses the <b>collect</b> function. If you want to
+collect into multiple lists, use the <b>with-collect</b> macro.</p>
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+ </body></html>
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/doc/compose.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/doc/compose.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,59 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Function COMPOSE</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Function</i> <b>COMPOSE</b></p>
+
+<p><p><b>Syntax:</b></p>
+
+<p><p><b>compose</b> <i>function* <tt>=></tt> composite-function</i></p>
+
+<p><p><b>Arguments and Values:</b></p>
+
+<p><p><i>function</i>---a <i><a href="http://www.lispworks.com/documentation/HyperSpec/Body/glo_f.html#function_designator">function designator</a></i>.</p>
+
+<p><i>composite-function</i>---a <i>function</i>.
+
+<p><p><b>Description:</b></p>
+
+<p>Composes its arguments into a single composite function. All its
+arguments are assumed to designate functions which take one argument
+and return one argument.
+
+<p><tt>(funcall (compose f g) 42)</tt> is equivalent to <tt>(f (g
+42))</tt>. Composition is right-associative.
+
+<p><b>Examples:</b>
+
+<pre>
+;; Just to illustrate order of operations
+(defun 2* (x) (* 2 x))
+
+
+(funcall (compose #'1+ #'1+) 1) => 3
+(funcall (compose '1+ '2*) 5) => 11
+(funcall (compose #'1+ '2* '1+) 6) => 15
+</pre>
+
+<p><b>Notes:</b>
+<p>If you're dealing with multiple arguments and return values, the
+same concept can be used. Here is some code that could be useful:
+
+<pre>
+(defun mv-compose2 (f1 f2)
+ (lambda (&rest args)
+ (multiple-value-call f1 (apply f2 args))))
+
+(defun mv-compose (&rest functions)
+ (if functions
+ (reduce #'mv-compose2 functions)
+ #'values))
+</pre>
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: dependencies/trunk/cl-utilities-1.2.4/doc/copy-array.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/doc/copy-array.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,48 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Function COPY-ARRAY</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Function</i> <b>COPY-ARRAY</b></a></a> <p>
+<p><b>Syntax:</b><p>
+
+<p>
+
+<p><b>copy-array</b> <i>array <tt>&key</tt> undisplace</i> => <i>new-array</i>
+<p>
+<p><b>Arguments and Values:</b><p>
+<p>
+<i>array</i>---an <i>array</i>. <p>
+
+<i>undisplace</i>---a <i>generalized boolean</i>. The default is <i>false</i>.<p>
+
+<i>new-array</i>---an <i>array</i></a>. <p>
+
+<p>
+<p><b>Description:</b><p>
+
+<p>Shallow copies the contents of <i>array</i> into another array with
+equivalent properties. If <i>array</i> is displaced, then this
+function will normally create another displaced array with similar
+properties, unless <i>undisplace</i> is <i>true</i>, in which case the
+contents of <i>array</i> will be copied into a completely new, not
+displaced, array.</p>
+
+<p><p><b>Examples:</b></p>
+<pre>
+(copy-array #(1 2 3)) => #(1 2 3)
+
+(let ((array #(1 2 3)))
+ (eq (copy-array array) array)) => NIL
+</pre>
+
+<p><p><b>Side Effects:</b> None.</p>
+
+<p><p><b>Affected By:</b> None.</p>
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: dependencies/trunk/cl-utilities-1.2.4/doc/expt-mod.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/doc/expt-mod.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,60 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Function EXPT-MOD</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Function</i> <b>EXPT-MOD</b></a></a> <p>
+<p><b>Syntax:</b><p>
+
+<p><b>expt-mod</b> <i>n exponent divisor</i> => <i>result</i>
+<p>
+<p><b>Arguments and Values:</b><p>
+<p>
+<i>n</i>---a <i>number</i></a>. <p>
+
+<i>exponent</i>---a <i>number</i></a>. <p>
+
+<i>divisor</i>---a <i>number</i></a>. <p>
+
+<i>result</i>---a <i>number</i></a>. <p>
+
+<p>
+<p><b>Description:</b><p>
+<p>
+<b>expt-mod</b> returns <i>n</i> raised to the <i>exponent</i> power,
+modulo <i>divisor</i>. <tt>(expt-mod n exponent divisor)</tt> is
+equivalent to <tt>(mod (expt n exponent) divisor)</tt>.
+
+<p>
+<p><b>Exceptional situations:</b><p>
+<p>
+
+<p>The exceptional situations are the same as those for <tt>(mod (expt
+n exponent) divisor)</tt>.
+
+<p><p><b>Notes:</b></p>
+
+<p>One might wonder why we shouldn't simply write <tt>(mod (expt n
+exponent) divisor)</tt>. This function exists because the naïve
+way of evaluating <tt>(mod (expt n exponent) divisor)</tt> produces a
+gigantic intermediate result, which kills performance in applications
+which use this operation heavily. The operation can be done much more
+efficiently. Usually the compiler does this optimization
+automatically, producing very fast code. However, we can't
+<i>depend</i> on this behavior if we want to produce code that is
+guaranteed not to perform abysmally on some Lisp implementations.
+
+<p>Therefore cl-utilities provides a standard interface to this
+composite operation which uses mediocre code by default. Specific
+implementations can usually do much better, but some do much
+worse. We can get the best of both by simply using the same interface
+and doing read-time conditionalization within cl-utilities to get
+better performance on compilers like SBCL and Allegro CL which
+optimize this operation.
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: dependencies/trunk/cl-utilities-1.2.4/doc/extremum.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/doc/extremum.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,155 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Function EXTREMUM, EXTREMA, N-MOST-EXTREME</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Function</i> <b>EXTREMUM, EXTREMA, N-MOST-EXTREME</b></a></a> <p>
+<p><b>Syntax:</b><p>
+
+<p>
+
+<p><b>extremum</b> <i>sequence predicate <tt>&key</tt> key (start 0) end</i> => <i>morally-smallest-element</i><p>
+<p><b>extrema</b> <i>sequence predicate <tt>&key</tt> key (start 0) end</i> => <i>morally-smallest-elements</i><p>
+<p><b>n-most-extreme</b> <i>n sequence predicate <tt>&key</tt> key (start 0) end</i> => <i>n-smallest-elements</i><p>
+<p>
+<p><b>Arguments and Values:</b><p>
+<p>
+<i>sequence</i>---a <i>proper sequence</i></a>. <p>
+
+<i>predicate</i>---a <i>designator</i> for a <i>function</i> of two
+arguments that returns a <i>generalized boolean</i>. <p>
+
+<i>key</i>---a <i>designator</i> for a <i>function</i> of one
+argument, or <b>nil</b>. <p>
+
+<i>start, end</i>---bounding index designators of <i>sequence</i>. The
+defaults for start and end are 0 and <b>nil</b>, respectively.<p>
+
+<i>morally-smallest-element</i>---the element of <i>sequence</i> that
+would appear first if the sequence were ordered according to <a
+class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/fun_sortcm_stable-sort.html"><b>sort</b></a>
+using <i>predicate</i> and <i>key</i>
+
+<p><i>morally-smallest-elements</i>---the identical elements of
+<i>sequence</i> that would appear first if the sequence were ordered
+according to <a class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/fun_sortcm_stable-sort.html"><b>sort</b></a>
+using <i>predicate</i> and <i>key</i>. If <i>predicate</i> states that
+neither of two objects is before the other, they are considered
+identical.
+
+<i>n</i>---a positive integer<p>
+
+<i>n-smallest-elements</i>---the <i>n</i> elements of <i>sequence</i> that
+would appear first if the sequence were ordered according to <a
+class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/fun_sortcm_stable-sort.html"><b>sort</b></a>
+using <i>predicate</i> and <i>key</i>
+
+<p>
+<p><b>Description:</b><p>
+<p>
+<b>extremum</b> returns the element of <i>sequence</i> that would
+appear first if the subsequence of <i>sequence</i> specified by
+<i>start</i> and <i>end</i> were ordered according to <a
+class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/fun_sortcm_stable-sort.html"><b>sort</b></a>
+using <i>predicate</i> and <i>key</i>.
+
+
+<p><p><b>extremum</b> determines the relationship between two elements
+by giving keys extracted from the elements to the
+<i>predicate</i>. The first argument to the <i>predicate</i> function
+is the part of one element of <i>sequence</i> extracted by the
+<i>key</i> function (if supplied); the second argument is the part of
+another element of <i>sequence</i> extracted by the <i>key</i>
+function (if supplied). <i>Predicate</i> should return <i>true</i> if
+and only if the first argument is strictly less than the second (in
+some appropriate sense). If the first argument is greater than or
+equal to the second (in the appropriate sense), then the
+<i>predicate</i> should return <i>false</i>. <p>
+
+<p>The argument to the <i>key</i> function is the <i>sequence</i>
+element. The return value of the <i>key</i> function becomes an
+argument to <i>predicate</i>. If <i>key</i> is not supplied or
+<b>nil</b>, the <i>sequence</i> element itself is used. There is no
+guarantee on the number of times the <i>key</i> will be called. <p>
+
+<p>If the <i>key</i> and <i>predicate</i> always return, then the
+operation will always terminate. This is guaranteed even if the
+<i>predicate</i> does not really consistently represent a total order
+(in which case the answer may be wrong). If the <i>key</i>
+consistently returns meaningful keys, and the <i>predicate</i> does
+reflect some total ordering criterion on those keys, then the answer
+will be right <p>
+
+<p>The <i>predicate</i> is assumed to consider two elements <tt>x</tt>
+and <tt>y</tt> to be equal if <tt>(funcall </tt><i>predicate</i><tt>
+</tt><i>x</i><tt> </tt><i>y</i><tt>)</tt> and <tt>(funcall
+</tt><i>predicate</i><tt> </tt><i>y</i><tt> </tt><i>x</i><tt>)</tt>
+are both <i>false</i>.
+
+
+<p>The return value of <tt>(extremum predicate sequence :key key)</tt>
+can be defined as <tt>(elt (<a class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/fun_sortcm_stable-sort.html"><b>sort</b></a>
+predicate (subseq sequence start end) :key key) 0)</tt> except when
+<i>sequence</i> is empty (see Exceptional Situations), but may use
+faster (less asymptotically complex) algorithms to find this answer.
+
+<p><b>extrema</b> is similar to <b>extremum</b>, but it returns a list
+of values. There can be more than one extremum, as determined by
+<i>predicate</i>, and with <b>extremum</b> the choice of which
+extremum to return is arbitrary. <b>extrema</b> returns all the
+possible values which <i>predicate</i> determines to be equal.
+
+<p><b>n-most-extreme</b> returns a list of <i>n</i> values without
+testing for equality. It orders <i>sequence</i> in the same way as
+<b>extremum</b> and <b>extrema</b>, then returns the first <i>n</i>
+elements of the sorted sequence.
+
+<p>
+<p><b>Exceptional situations:</b><p>
+<p>
+
+<p>If <i>sequence</i> is empty, then the error <i>no-extremum</i> is
+signalled. Invoking the <b>continue</b> restart will cause
+<b>extremum</b> to return <b>nil</b>.
+
+
+<p>Should be prepared to signal an error of type <b>type-error</b> if
+<i>sequence</i> is not a proper sequence.
+
+<p>If there are fewer than <i>n</i> values in the part of
+<i>sequence</i> that <b>n-most-extreme</b> may operate on, it returns
+all the values it can in sorted order and signals the warning
+<b>n-most-extreme-not-enough-elements</b>. This warning stores the
+given values for <i>n</i> and the relevant subsequence, and they may
+be accessed with <b>n-most-extreme-not-enough-elements-n</b> and
+<b>n-most-extreme-not-enough-elements-subsequence</b>, respectively.
+
+<p><p><b>Implementation notes:</b></p>
+
+<p>There are two implementations of this function included in
+cl-utilities, which should only concern you if you want to squeeze out
+more efficiency, since the versions perform differently on different
+inputs.
+
+<p>The function <b>extremum-fastkey</b> is used exactly like
+<b>extremum</b>, but it calls <i>key</i> fewer times. If <i>key</i> is
+fast, <b>extremum-fastkey</b> is slower than regular <b>extremum</b>,
+but if <i>key</i> is hard to compute you can get significant gains in
+speed. The <b>extremum-fastkey</b> function is more complicated than
+<b>extremum</b>, and therefore may be more likely to contain
+bugs. That said, it doesn't seem buggy.</p>
+
+<p>Don't worry about the performance of passing <tt>#'identity</tt> as
+<i>key</i>. This is optimized by a compiler macro.</p>
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: dependencies/trunk/cl-utilities-1.2.4/doc/index.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/doc/index.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,58 @@
+<html>
+<head>
+ <title>cl-utilities manual</title>
+ <link rel="stylesheet" href="style.css" type="text/css" />
+</head>
+<body>
+
+<h1>cl-utilities manual</h1>
+
+<p>Everybody writes some utilities because they're not part of the
+standard but they're so broadly useful. This results in a lot of wheel
+reinvention, and most reinventions are not as good as they should
+be. The cl-utilities project is an actively maintained collection of
+some of these utilities, with high-quality public-domain
+implementations and decent documentation.
+
+<h2>Table of contents:</h2>
+
+<ul style="list-style-type: none;">
+
+<li><a href="split-sequence.html">SPLIT-SEQUENCE, SPLIT-SEQUENCE-IF,
+SPLIT-SEQUENCE-IF-NOT</a>. Used for splitting sequences.</li>
+
+<li><a href="extremum.html">EXTREMUM, EXTREMA,
+N-MOST-EXTREME</a>: Finding extreme values in sequences based on
+user-defined criteria.</li>
+
+<li><a href="read-delimited.html">READ-DELIMITED</a> reads from a
+sequence delimited somehow, in a somewhat inconvenient but hopefully
+efficient way.</li>
+
+<li><a href="expt-mod.html">EXPT-MOD</a>, an interface for calculating
+<tt>(mod (expt n e) m)</tt> efficiently across implementations.</li>
+
+<li><a href="with-unique-names.html">WITH-UNIQUE-NAMES, née
+WITH-GENSYMS</a>. A classic macro-writing macro for preventing
+variable capture.</li>
+
+<li><a href="collecting.html">COLLECTING, WITH-COLLECTORS</a>. Some
+macros for clearly and efficiently collecting items into lists.</li>
+
+<li><a href="once-only.html">ONCE-ONLY</a>, a classic macro-writing
+macro for preventing multiple evaluation.</li>
+
+<li><a href="rotate-byte.html">ROTATE-BYTE</a> rotates bits in a byte</li>
+
+<li><a href="copy-array.html">COPY-ARRAY</a> shallow copies arrays.</li>
+
+<li><a href="compose.html">COMPOSE</a>. Composes functions.</li>
+
+</ul>
+
+<p><hr>Public domain, maintained by <a
+href="mailto:sketerpot at gmail.com">Peter Scott</a>. For more information, see
+the <a href="http://common-lisp.net/project/cl-utilities/">home page</a>.
+
+</body>
+</html>
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/doc/once-only.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/doc/once-only.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,40 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/transitional.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Macro ONCE-ONLY</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Macro</i> <b>ONCE-ONLY</b></a></a> <p>
+<p><b>Syntax:</b><p>
+
+<p>
+
+<p><b>once-only</b> <i>(name*) form*</i>
+<p>
+<p><b>Arguments and Values:</b><p>
+<p>
+<i>name</i>---a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/glo_s.html#symbol"><i>symbol</i></a></a>. <p>
+
+<i>form</i>---a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/glo_f.html#form"><i>form</i></a></a>. <p>
+
+<p>
+<p><b>Description:</b><p>
+<p>Meant to be used in macro code, <b>once-only</b> guards against
+multiple evaluation of its arguments in macroexpansion code. Any
+concise description would be far too vague to grasp, but <a
+href="http://groups.google.com/group/comp.lang.lisp/browse_frm/thread/1783554653afad7f/f6357129c8c1c002?rnum=1&_done=%2Fgroup%2Fcomp.lang.lisp%2Fbrowse_frm%2Fthread%2F1783554653afad7f%2F940b6ebd2d1757f4%3F#doc_f6357129c8c1c002">this
+thread on comp.lang.lisp</a> does a decent job of explaining what
+<b>once-only</b> does.
+
+<p><p><b>Notes:</b></p>
+
+<p>The description here is frustratingly non-descriptive, and I
+apologize for that. If you understand <b>once-only</b> and can give a
+better explanation, I would be very grateful—not to mention
+completely awed.
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: dependencies/trunk/cl-utilities-1.2.4/doc/read-delimited.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/doc/read-delimited.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,88 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Function READ-DELIMITED</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Function</i> <b>READ-DELIMITED</b></p>
+
+<p><p><b>Syntax:</b></p>
+
+<p><p><b>read-delimited</b> <i>sequence stream <tt>&key </tt> start end delimiter test key</i> => <i>position, delimited-p</i></p>
+
+<p><p><b>Arguments and Values:</b></p>
+
+<p><p><i>sequence</i>---a <i>sequence</i>.</p>
+
+<p><i>stream</i>---an <i>input stream</i>.</p>
+<p><i>start, end</i>---<i>bounding index designators</i> of
+<i>sequence</i>. The defaults for <i>start</i> and <i>end</i> are 0
+and <b>nil</b>, respectively.
+
+<p><i>delimiter</i>---a <i>character</i>. It defaults to #\newline.</p>
+<p><i>test</i>---a <i>designator</i> for a <i>function</i> of two
+<i>arguments</i> that returns a <i>generalized boolean</i>.</p>
+
+<p><i>key</i>---a <i>designator</i> for a <i>function</i> of one
+argument, or <b>nil</b>.</p>
+<p><i>position</i>---an <i>integer</i> greater than or equal to zero,
+and less than or equal to the <i>length</i> of the sequence.</p>
+
+<p><i>delimited-p</i>---the result of the last invokation of <i>test</i></p>
+
+<p><p><b>Description:</b></p>
+
+<p><p>Destructively modifies <i>sequence</i> by replacing
+<i>elements</i> of <i>sequence</i> <i>bounded</i> by <i>start</i> and
+<i>end</i> with <i>elements</i> read from <i>stream</i>.</p>
+
+<p><p><i>Test</i> is called with the actual read character, converted
+by applying <i>key</i> to it, as the first and <i>delimiter</i> as the
+second argument.</p>
+
+<p><p>If a character is read for which (funcall <i>test</i> (funcall
+<i>key</i> <b>char</b>) <i>delimiter</i>) is non-nil,
+<b>read-delimited</b> terminates the copying even before reaching
+<i>end of file</i> or the <i>end</i> of the <i>bounding
+designator</i>.</p>
+
+<p><p><b>read-delimited</b> returns the index of the first
+<i>element</i> of <i>sequence</i> that was not updated as the first
+and the result of the last invokation of <i>test</i> as the second
+value.</p>
+
+<p><p><i>Sequence</i> is destructively modified by copying successive
+<i>elements</i> into it from <i>stream</i>. If the <i>end of file</i>
+for <i>stream</i> is reached before copying all <i>elements</i> of the
+subsequence, then the extra <i>elements</i> near the end of
+<i>sequence</i> are not updated.</p>
+
+<p><b>Exceptional situations:</b>
+
+<p>If <i>start</i> and/or <i>end</i> are out of bounds, or if
+<i>start</i> > <i>end</i>, then a
+<b>read-delimited-bounds-error</b> error is signalled. This error is
+passed the values of <i>start</i>, <i>end</i>, and <i>sequence</i>,
+which can be read with <b>read-delimited-bounds-error-start</b>,
+<b>read-delimited-bounds-error-end</b>, and
+<b>read-delimited-bounds-error-sequence</b>,
+respectively.
+
+<p><p><b>Implementation notes:</b></p>
+
+<p>This is one of the more complex utilities, and the amount of
+argument checking needed to do it properly is daunting. An amazing 76%
+of the code is spent on making sure that the bounds are valid and in
+order, and on what to do if they aren't. Once you remove all that, the
+actual function which does all the work is quite simple, and unlikely
+to contain bugs.</p>
+
+<p>The design of this function makes it a little annoying to use, but
+it is more efficient. If you need something more high-level, this
+could be built on top of <b>read-delimited</b> fairly easily.</p>
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: dependencies/trunk/cl-utilities-1.2.4/doc/rotate-byte.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/doc/rotate-byte.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,65 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Function ROTATE-BYTE</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Function</i> <b>ROTATE-BYTE</b></a></a> <p>
+<p><b>Syntax:</b><p>
+
+<p>
+
+<p><b>rotate-byte</b> <i>count bytespec integer</i> => <i>result</i>
+<p>
+<p><b>Arguments and Values:</b><p>
+<p>
+<i>count</i>---an <i>integer</i></a>. <p>
+
+<i>bytespec</i>---a <i>byte specifier</i></a>. <p>
+
+<i>integer</i>---an <i>integer</i></a>. <p>
+
+<i>result</i>---an <i>integer</i></a>. <p>
+
+<p>
+<p><b>Description:</b><p>
+
+<p>Rotates a field of bits within <i>integer</i>; specifically, returns an
+integer that contains the bits of <i>integer</i> rotated <i>count</i> times
+leftwards within the byte specified by <i>bytespec</i>, and elsewhere
+contains the bits of <i>integer</i>.</p>
+
+<p><p><b>Examples:</b></p>
+<pre>
+(rotate-byte 3 (byte 32 0) 3) => 24
+(rotate-byte 3 (byte 5 5) 3) => 3
+(rotate-byte 6 (byte 8 0) -3) => -129
+</pre>
+
+<p><p><b>Side Effects:</b> None.</p>
+
+<p><p><b>Affected By:</b> None.</p>
+
+<p><p><b>Exceptional Situations:</b> None.</p>
+
+<p><p><b>See Also:</b></p>
+
+<p><a class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/fun_bytecm_by_yte-position.html"><b>byte</b></a>,
+<a class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/fun_dpb.html"><b>dpb</b></a>, <a
+class="hyperspec" href ="
+http://www.lispworks.com/documentation/HyperSpec/Body/acc_ldb.html"><b>ldb</b></a>
+
+<p><b>Implementation notes</b>
+
+<p>SBCL provides the sb-rotate-byte extension to do this
+efficiently. On SBCL, cl-utilities uses this extension
+automatically. On other implementations, portable Common Lisp code is
+used instead.
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: dependencies/trunk/cl-utilities-1.2.4/doc/split-sequence.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/doc/split-sequence.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,106 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Function SPLIT-SEQUENCE, SPLIT-SEQUENCE-IF, SPLIT-SEQUENCE-IF-NOT</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><p><i>Function</i> <b>SPLIT-SEQUENCE, SPLIT-SEQUENCE-IF, SPLIT-SEQUENCE-IF-NOT</b></p>
+
+<p><p><b>Syntax:</b></p>
+
+<p><p><b>split-sequence</b> <i>delimiter sequence <tt>&key</tt> count remove-empty-subseqs from-end start end test test-not key</i> => <i>list, index</i></p>
+<p><p><b>split-sequence-if</b> <i>predicate sequence <tt>&key</tt> count remove-empty-subseqs from-end start end key</i> => <i>list, index</i></p>
+
+<p><p><b>split-sequence-if-not</b> <i>predicate sequence <tt>&key</tt> count remove-empty-subseqs from-end start end key</i> => <i>list, index</i></p>
+
+<p><p><b>Arguments and Values:</b></p>
+
+<p><p><i>delimiter</i>---an <i>object</i>.</p>
+
+<p><i>predicate</i>---a <i>designator</i> for a <i>function</i> of one <i>argument</i> that returns a <i>generalized boolean</i>.</p>
+<p><i>sequence</i>---a <i>proper sequence</i>.</p>
+
+<p><i>count</i>---an <i>integer</i> or <b>nil</b>. The default is <b>nil</b>.</p>
+<p><i>remove-empty-subseqs</i>---a <i>generalized boolean</i>. The default is <i>false</i>.</p>
+
+<p><i>from-end</i>---a <i>generalized boolean</i>. The default is <i>false</i>.</p>
+<p><i>start, end</i>---<i>bounding index designators</i> of <i>sequence</i>. The defaults for </i>start</i> and <i>end</i> are <tt>0</tt> and <b>nil</b>, respectively.</p>
+
+<p><i>test</i>---a <i>designator</i> for a <i>function</i> of two <i>arguments</i> that returns a <i>generalized boolean</i>.</p>
+<p><i>test-not</i>---a <i>designator</i> for a <i>function</i> of two <i>arguments</i> that returns a <i>generalized boolean</i>.</p>
+
+<p><i>key</i>---a <i>designator</i> for a <i>function</i> of one <i>argument</i>, or <b>nil</b>.</p>
+<p><i>list</i>---a <i>proper sequence</i>.</p>
+
+<p><i>index</i>---an <i>integer</i> greater than or equal to zero, and less than or equal to the <i>length</i> of the <i>sequence</i>.</p>
+
+<p><p><b>Description:</b></p>
+
+<p><p>Splits <i>sequence</i> into a list of subsequences delimited by objects <i>satisfying the test</i>.
+
+
+<p><i>List</i> is a list of sequences of the same kind as <i>sequence</i> that has elements consisting of subsequences of <i>sequence</i> that were delimited in the argument by elements <i>satisfying the test</i>. <i>Index</i> is an index into <i>sequence</i> indicating the unprocessed region, suitable as an argument to <a class="hyperspec" href =" http://www.lispworks.com/documentation/HyperSpec/Body/acc_subseq.html"><b>subseq</b></a> to continue processing in the same manner if desired.
+
+
+<p>The <i>count</i> argument, if supplied, limits the number of subsequences in the first return value; if more than <i>count</i> delimited subsequences exist in <i>sequence</i>, the <i>count</i> leftmost delimited subsequences will be in order in the first return value, and the second return value will be the index into <i>sequence</i> at which processing stopped.
+
+<p>If <i>from-end</i> is non-null, <i>sequence</i> is conceptually processed from right to left, accumulating the subsequences in reverse order; <i>from-end</i> only makes a difference in the case of a non-null <i>count</i> argument. In the presence of <i>from-end</i>, the <i>count</i> rightmost delimited subsequences will be in the order that they are in <i>sequence</i> in the first return value, and the second is the index indicating the end of the unprocessed region.
+
+
+<p>The <i>start</i> and <i>end</i> keyword arguments permit a certain subsequence of the <i>sequence</i> to be processed without the need for a copying stage; their use is conceptually equivalent to partitioning the subsequence delimited by <i>start</i> and <i>end</i>, only without the need for copying.
+
+<p>If <i>remove-empty-subseqs</i> is null (the default), then empty subsequences will be included in the result.
+
+
+<p>In all cases, the subsequences in the first return value will be in the order that they appeared in <i>sequence</i>.
+
+<p><p><b>Examples:</b></p>
+
+<p><pre>
+ (split-sequence:SPLIT-SEQUENCE #\Space "A stitch in time saves nine.")
+=> ("A" "stitch" "in" "time" "saves" "nine.")
+ 28
+ (split-sequence:SPLIT-SEQUENCE #\, "foo,bar ,baz, foobar , barbaz,")
+=> ("foo" "bar " "baz" " foobar " " barbaz" "")
+ 30
+</pre>
+
+<p><p><b>Implementation notes:</b></p>
+
+<p>This code was written various people, and the license is
+unknown. Since multiple people worked on it collaboratively and none
+of them seem interested in keeping their intellectual property rights
+to it, I'll assume that it is in the public domain (since the process
+that produced it seems like the very essence of public domain). If
+this is incorrect, please <a href="mailto:sketerpot at gmail.com">contact
+me</a> so we can get it straightened out.</p>
+
+<p>The implementation itself is mature and well tested, and it is
+widely used. The code should be fast enough for most people, but be
+warned: it was written with vectors in mind, with list manipulation as
+an afterthought. It does a lot of things that are quick on vectors but
+slow on lists, and this can result in many orders of magnitude
+slowdown in list benchmarks versus code written for lists. If this is
+a problem for you, it should be straightforward to write your own,
+such as the (more limited, not API compatible) example function given
+by Szymon in <a
+href="http://common-lisp.net/pipermail/cl-utilities-devel/2006-May/000011.html">this
+mailing list post</a>:</p>
+
+<p><pre>
+(defun split-list-if (test list &aux (start list) (end list))
+ (loop while (and end (setq start (member-if-not test end)))
+ collect (ldiff start (setq end (member-if test start)))))
+</pre></p>
+
+<p>If this is an issue for enough people, I could optimize the code
+and fix this problem. I'm reluctant to do that, however, since the
+code works and is tested. It's usually more important to be correct
+and non-buggy than to be fast, and I have been known to introduce
+bugs.</p>
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</body></html>
Added: dependencies/trunk/cl-utilities-1.2.4/doc/style.css
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/doc/style.css Tue Jan 26 15:20:07 2010
@@ -0,0 +1,16 @@
+pre {
+ margin-right: 0.5cm;
+ border: thin black solid;
+ background: #F3EEEE;
+ padding: 0.5em;
+}
+
+h1 {
+ font-family: sans-serif;
+ font-variant: small-caps;
+}
+
+h2 {
+ font-family: sans-serif;
+ font-size: medium;
+}
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/doc/with-unique-names.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/doc/with-unique-names.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,104 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
+<HTML>
+<HEAD>
+ <TITLE>Macro WITH-UNIQUE-NAMES</TITLE>
+ <LINK REL="stylesheet" HREF="style.css" type="text/css">
+</HEAD>
+<BODY>
+
+<p><i>Macro</i> <b>WITH-UNIQUE-NAMES</b></p><p><b>Syntax:</b></p><p>
+
+<b>with-unique-names</b> <i>({<i>var</i> | (<i>var</i>
+ <i>prefix</i>)}<b>*</b>) <i>declaration</i><b>*</b>
+ <i>form</i><b>*</b></i> => <i><i>result</i><b>*</b></i>
+
+
+ </p><p><b>Arguments and Values:</b></p><p>
+ <p><i>var</i>---a <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol"><i>symbol</i></a>;
+ not <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_e.htm#evaluate"><i>evaluate</i></a>d.</p>
+ <p><i>prefix</i>---a <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#string_designator"><i>string designator</i></a>; not
+ <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_e.htm#evaluate"><i>evaluate</i></a>d. The default is <i>var</i>.</p>
+
+ <p><i>declaration</i>---a <a href ="
+ http://www.lispworks.com/documentation/HyperSpec/Body/sym_declare.html"><b>declare</b></a>
+ <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_e.htm#expression"><i>expression</i></a>;
+ not <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_e.htm#evaluate"><i>evaluate</i></a>d.</p>
+ <p><i>form</i>---a <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#form"><i>form</i></a>.</p>
+ <p><i>results</i>---the <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_v.htm#value"><i>value</i></a>s
+ <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_r.htm#return"><i>return</i></a>ed by the <i>form</i>s.</p>
+
+ </p><p><b>Description:</b></p><p> <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_e.htm#Execute"><i>Execute</i></a>s
+ a series of <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#form"><i>form</i></a>s
+ with each
+ <i>var</i> <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_b.htm#bound"><i>bound</i></a> to a <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#fresh"><i>fresh</i></a>,
+ <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_u.htm#uninterned"><i>uninterned</i></a> <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol"><i>symbol</i></a>. The
+ <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_u.htm#uninterned"><i>uninterned</i></a> <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#symbol"><i>symbol</i></a> is created as if by
+ a <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#call"><i>call</i></a> to <a href =" http://www.lispworks.com/documentation/HyperSpec/Body/fun_gensym.html"><b>gensym</b></a> with the
+ <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#string"><i>string</i></a> denoted by <i>prefix</i>---or, if
+ <i>prefix</i> is not supplied, the <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#string"><i>string</i></a>
+
+ denoted by <i>var</i>---as <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#argument"><i>argument</i></a>.
+ <p></p> The <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_v.htm#variable"><i>variable</i></a>
+ <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_b.htm#binding"><i>binding</i></a>s
+ created are <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_l.htm#lexical"><i>lexical</i></a>
+ unless <a
+ HREF="http://www.lispworks.com/documentation/HyperSpec/Body/dec_specia.htm#special"><b>special</b></a>
+
+ <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_d.htm#declaration"><i>declaration</i></a>s are specified.
+ <p></p>
+ The <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#form"><i>form</i></a>s are <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_e.htm#evaluate"><i>evaluate</i></a>d in order, and
+ the <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_v.htm#value"><i>value</i></a>s of all but the last are discarded (that
+ is, the body is an <a HREF="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_i.htm#implicit_progn"><i>implicit progn</i></a>).
+ </p><p><b>Examples:</b></p><p>
+<pre>
+
+ (with-unique-names (sym1) sym1) => #:SYM13142
+ (with-unique-names ((sym1 "SYM1-")) sym1) => #:SYM1-3143
+ (find-symbol "SYM1-3143") => NIL, NIL
+ (with-unique-names ((sym #\Q)) sym) => #:Q3144
+ (with-unique-names ((sym1 :sym1-)) sym1) => #:SYM1-3145
+ (with-unique-names (sym1) (symbol-package sym1)) => NIL
+ (with-unique-names (sym8) (eq sym8 sym8)) => T
+ (with-unique-names (sym9) (set sym9 42) (symbol-value sym9)) => 42
+</pre>
+
+ </p><p><b>Side Effects:</b></p><p>
+ Might increment <a href =" http://www.lispworks.com/documentation/HyperSpec/Body/var_stgensym-counterst.html"><b>*gensym-counter*</b></a> once for each
+ <i>var</i>.
+ </p><p><b>Affected by:</b></p><p> <a href ="
+ http://www.lispworks.com/documentation/HyperSpec/Body/var_stgensym-counterst.html"><b>*gensym-counter*</b></a>
+
+ </p><p><b>Exceptional Situations:</b></p><p>
+ None.
+ </p><p><b>See Also:</b></p><p>
+<a href =" http://www.lispworks.com/documentation/HyperSpec/Body/fun_gensym.html"><b>gensym</b></a>, <a href =" http://www.lispworks.com/documentation/HyperSpec/Body/speope_letcm_letst.html"><b>let</b></a></b>
+ </p>
+ </p>
+
+<p><b>Notes:</b>
+<p>This is an extension of the classic macro <b>with-gensyms</b>. In
+fact, cl-utilities also exports <b>with-gensyms</b>, and it can be
+used as usual. The exported <b>with-gensyms</b> is actually just an
+alias for <b>with-unique-names</b> which gives a warning at
+compile-time if the extensions of <b>with-unique-names</b> are used.
+
+<p>You are encouraged to use <b>with-unique-names</b> instead of
+<b>with-gensyms</b> because it is a little more flexible and because
+it tells what is going on rather than how it works. This is a somewhat
+controversial point, so go ahead and use whichever you like if you
+have an opinion on it. But if you're a newbie who honestly doesn't
+care, please use <b>with-unique-names</b>.
+
+<p class="footer"><hr><a href="index.html">Manual Index</a></p>
+
+</BODY>
+</HTML>
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/expt-mod.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/expt-mod.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,38 @@
+(in-package :cl-utilities)
+
+;; This is portable Common Lisp, but implementation-specific code may
+;; improve performance considerably.
+(defun expt-mod (n exponent modulus)
+ "As (mod (expt n exponent) modulus), but more efficient."
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ ;; It's much faster on SBCL and ACL to use the simple method, and
+ ;; trust the compiler to optimize it. This may be the case on other
+ ;; Lisp implementations as well.
+ #+(or sbcl allegro) (mod (expt n exponent) modulus)
+ #-(or sbcl allegro)
+ (if (some (complement #'integerp) (list n exponent modulus))
+ (mod (expt n exponent) modulus)
+ (loop with result = 1
+ for i of-type fixnum from 0 below (integer-length exponent)
+ for sqr = n then (mod (* sqr sqr) modulus)
+ when (logbitp i exponent) do
+ (setf result (mod (* result sqr) modulus))
+ finally (return result))))
+
+;; If the compiler is going to expand compiler macros, we should
+;; directly inline the simple expansion; this lets the compiler do all
+;; sorts of fancy optimizations based on type information that
+;; wouldn't be used to optimize the normal EXPT-MOD function.
+#+(or sbcl allegro)
+(define-compiler-macro expt-mod (n exponent modulus)
+ `(mod (expt ,n ,exponent) ,modulus))
+
+
+;; Here's some benchmarking code that may be useful. I probably
+;; completely wasted my time declaring ITERATIONS to be a fixnum.
+#+nil
+(defun test (&optional (iterations 50000000))
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))
+ (fixnum iterations))
+ (time (loop repeat iterations do (mod (expt 12 34) 235)))
+ (time (loop repeat iterations do (expt-mod 12 34 235))))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/extremum.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/extremum.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,167 @@
+(in-package :cl-utilities)
+
+(define-condition no-extremum (error) ()
+ (:report "Cannot find extremum of empty sequence")
+ (:documentation "Raised when EXTREMUM is called on an empty
+sequence, since there is no morally smallest element"))
+
+(defun comparator (test &optional (key #'identity))
+ "Comparison operator: auxilliary function used by EXTREMUM"
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (lambda (a b) (if (funcall test
+ (funcall key a)
+ (funcall key b))
+ a
+ b)))
+
+;; This optimizes the case where KEY is #'identity
+(define-compiler-macro comparator (&whole whole test
+ &optional (key #'identity))
+ (if (eql key #'identity)
+ `(lambda (a b)
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (if (funcall ,test a b) a b))
+ whole))
+
+;; The normal way of testing the if length of a proper sequence equals
+;; zero is to just use (zerop (length sequence)). And, while some
+;; implementations may optimize this, it's probably a good idea to
+;; just write an optimized version and use it. This method can speed
+;; up list length testing.
+(defun zero-length-p (sequence)
+ "Is the length of SEQUENCE equal to zero?"
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (or (null sequence)
+ (when (vectorp sequence)
+ (zerop (length sequence)))))
+
+(declaim (inline zero-length-p))
+
+;; Checks the length of the subsequence of SEQUENCE specified by START
+;; and END, and if it's 0 then a NO-EXTREMUM error is signalled. This
+;; should only be used in EXTREMUM functions.
+(defmacro with-check-length ((sequence start end) &body body)
+ (once-only (sequence start end)
+ `(if (or (zero-length-p ,sequence)
+ (>= ,start (or ,end (length ,sequence))))
+ (restart-case (error 'no-extremum)
+ (continue ()
+ :report "Return NIL instead"
+ nil))
+ (progn , at body))))
+
+;; This is an extended version which takes START and END keyword
+;; arguments. Any spec-compliant use of EXTREMUM will also work with
+;; this extended version.
+(defun extremum (sequence predicate
+ &key (key #'identity) (start 0) end)
+ "Returns the element of SEQUENCE that would appear first if the
+sequence were ordered according to SORT using PREDICATE and KEY using
+an unstable sorting algorithm. See http://www.cliki.net/EXTREMUM for
+the full specification."
+ (with-check-length (sequence start end)
+ (reduce (comparator predicate key) sequence
+ :start start :end end)))
+
+;; This optimizes the case where KEY is #'identity
+(define-compiler-macro extremum (&whole whole sequence predicate
+ &key (key #'identity) (start 0) end)
+ (if (eql key #'identity)
+ (once-only (sequence predicate start end)
+ `(with-check-length (,sequence ,start ,end)
+ (locally (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (reduce (comparator ,predicate) ,sequence
+ :start ,start :end ,end))))
+ whole))
+
+;; This is an "optimized" version which calls KEY less. REDUCE is
+;; already so optimized that this will actually be slower unless KEY
+;; is expensive. And on CLISP, of course, the regular version will be
+;; much faster since built-in functions are ridiculously faster than
+;; ones implemented in Lisp. Be warned, this isn't as carefully tested
+;; as regular EXTREMUM and there's more that could go wrong.
+(defun extremum-fastkey (sequence predicate
+ &key (key #'identity) (start 0) end)
+ "EXTREMUM implemented so that it calls KEY less. This is only faster
+if the KEY function is so slow that calling it less often would be a
+significant improvement; ordinarily it's slower."
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (with-check-length (sequence start end)
+ (let* ((smallest (elt sequence 0))
+ (smallest-key (funcall key smallest))
+ (current-index 0)
+ (real-end (or end (1- most-positive-fixnum))))
+ (declare (type (integer 0) current-index real-end start)
+ (fixnum current-index real-end start))
+ (map nil #'(lambda (x)
+ (when (<= start current-index real-end)
+ (let ((x-key (funcall key x)))
+ (when (funcall predicate
+ x-key
+ smallest-key)
+ (setf smallest x)
+ (setf smallest-key x-key))))
+ (incf current-index))
+ sequence)
+ smallest)))
+
+;; EXTREMA and N-MOST-EXTREME are based on code and ideas from Tobias
+;; C. Rittweiler. They deal with the cases in which you are not
+;; looking for a single extreme element, but for the extreme identical
+;; elements or the N most extreme elements.
+
+(defun extrema (sequence predicate &key (key #'identity) (start 0) end)
+ (with-check-length (sequence start end)
+ (let* ((sequence (subseq sequence start end))
+ (smallest-elements (list (elt sequence 0)))
+ (smallest-key (funcall key (elt smallest-elements 0))))
+ (map nil
+ #'(lambda (x)
+ (let ((x-key (funcall key x)))
+ (cond ((funcall predicate x-key smallest-key)
+ (setq smallest-elements (list x))
+ (setq smallest-key x-key))
+ ;; both elements are considered equal if the predicate
+ ;; returns false for (PRED A B) and (PRED B A)
+ ((not (funcall predicate smallest-key x-key))
+ (push x smallest-elements)))))
+ (subseq sequence 1))
+ ;; We use NREVERSE to make this stable (in the sorting algorithm
+ ;; sense of the word 'stable').
+ (nreverse smallest-elements))))
+
+
+
+(define-condition n-most-extreme-not-enough-elements (warning)
+ ((n :initarg :n :reader n-most-extreme-not-enough-elements-n
+ :documentation "The number of elements that need to be returned")
+ (subsequence :initarg :subsequence
+ :reader n-most-extreme-not-enough-elements-subsequence
+ :documentation "The subsequence from which elements
+must be taken. This is determined by the sequence and the :start and
+:end arguments to N-MOST-EXTREME."))
+ (:report (lambda (condition stream)
+ (with-slots (n subsequence) condition
+ (format stream "There are not enough elements in the sequence ~S~% to return the ~D most extreme elements"
+ subsequence n))))
+ (:documentation "There are not enough elements in the sequence given
+to N-MOST-EXTREME to return the N most extreme elements."))
+
+(defun n-most-extreme (n sequence predicate &key (key #'identity) (start 0) end)
+ "Returns a list of the N elements of SEQUENCE that would appear
+first if the sequence were ordered according to SORT using PREDICATE
+and KEY with a stable sorting algorithm. If there are less than N
+elements in the relevant part of the sequence, this will return all
+the elements it can and signal the warning
+N-MOST-EXTREME-NOT-ENOUGH-ELEMENTS"
+ (check-type n (integer 0))
+ (with-check-length (sequence start end)
+ ;; This is faster on vectors than on lists.
+ (let ((sequence (subseq sequence start end)))
+ (if (> n (length sequence))
+ (progn
+ (warn 'n-most-extreme-not-enough-elements
+ :n n :subsequence sequence)
+ (stable-sort (copy-seq sequence) predicate :key key))
+ (subseq (stable-sort (copy-seq sequence) predicate :key key)
+ 0 n)))))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/once-only.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/once-only.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,31 @@
+;; The ONCE-ONLY macro is hard to explain, hard to understand, hard to
+;; write, hard to modify, and hard to live without once you figure out
+;; how to use it. It's used in macros to guard against multiple
+;; evaluation of arguments. My version is longer than most, but it
+;; does some error checking and it gives gensym'd variables more
+;; meaningful names than usual.
+
+(in-package :cl-utilities)
+
+(defun %check-once-only-names (names)
+ "Check that all of the NAMES are symbols. If not, raise an error."
+ ;; This only raises an error for the first non-symbol argument
+ ;; found. While this won't report multiple errors, it is probably
+ ;; more convenient to only report one.
+ (let ((bad-name (find-if-not #'symbolp names)))
+ (when bad-name
+ (error "ONCE-ONLY expected a symbol but got ~S" bad-name))))
+
+(defmacro once-only (names &body body)
+ ;; Check the NAMES list for validity.
+ (%check-once-only-names names)
+ ;; Do not touch this code unless you really know what you're doing.
+ (let ((gensyms (loop for name in names collect (gensym (string name)))))
+ `(let (,@(loop for g in gensyms
+ for name in names
+ collect `(,g (gensym ,(string name)))))
+ `(let (,,@(loop for g in gensyms for n in names
+ collect ``(,,g ,,n)))
+ ,(let (,@(loop for n in names for g in gensyms
+ collect `(,n ,g)))
+ , at body)))))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/package.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/package.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,49 @@
+(defpackage :cl-utilities
+ (:use :common-lisp)
+ (:export #:split-sequence
+ #:split-sequence-if
+ #:split-sequence-if-not
+ #:partition
+ #:partition-if
+ #:partition-if-not
+
+ #:extremum
+ #:no-extremum
+ #:extremum-fastkey
+ #:extrema
+ #:n-most-extreme
+ #:n-most-extreme-not-enough-elements
+ #:n-most-extreme-not-enough-elements-n
+ #:n-most-extreme-not-enough-elements-subsequence
+
+ #:read-delimited
+ #:read-delimited-bounds-error
+ #:read-delimited-bounds-error-start
+ #:read-delimited-bounds-error-end
+ #:read-delimited-bounds-error-sequence
+
+ #:expt-mod
+
+ #:collecting
+ #:collect
+ #:with-collectors
+
+ #:with-unique-names
+ #:with-gensyms
+ #:list-binding-not-supported
+ #:list-binding-not-supported-binding
+
+ #:once-only
+
+ #:rotate-byte
+
+ #:copy-array
+
+ #:compose))
+
+#+split-sequence-deprecated
+(defpackage :split-sequence
+ (:documentation "This package mimics SPLIT-SEQUENCE for compatibility with
+packages that expect that system.")
+ (:use :cl-utilities)
+ (:export #:split-sequence #:split-sequence-if #:split-sequence-if-not))
Added: dependencies/trunk/cl-utilities-1.2.4/package.sh
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/package.sh Tue Jan 26 15:20:07 2010
@@ -0,0 +1,21 @@
+#!/bin/sh
+
+mkdir cl-utilities-1.2.4
+mkdir cl-utilities-1.2.4/doc
+cp cl-utilities.asd package.sh collecting.lisp split-sequence.lisp expt-mod.lisp package.lisp compose.lisp extremum.lisp read-delimited.lisp test.lisp copy-array.lisp once-only.lisp rotate-byte.lisp with-unique-names.lisp README cl-utilities-1.2.4/
+cp doc/collecting.html doc/expt-mod.html doc/read-delimited.html doc/with-unique-names.html doc/compose.html doc/extremum.html doc/rotate-byte.html doc/copy-array.html doc/index.html doc/split-sequence.html doc/once-only.html doc/style.css cl-utilities-1.2.4/doc/
+
+rm -f cl-utilities-latest.tar.gz cl-utilities-latest.tar.gz.asc
+
+tar -czvf cl-utilities-1.2.4.tar.gz cl-utilities-1.2.4/
+ln -s ~/hacking/lisp/cl-utilities/cl-utilities-1.2.4.tar.gz ~/hacking/lisp/cl-utilities/cl-utilities-latest.tar.gz
+gpg -b -a ~/hacking/lisp/cl-utilities/cl-utilities-1.2.4.tar.gz
+ln -s ~/hacking/lisp/cl-utilities/cl-utilities-1.2.4.tar.gz.asc ~/hacking/lisp/cl-utilities/cl-utilities-latest.tar.gz.asc
+rm -Rf cl-utilities-1.2.4/
+
+scp cl-utilities-1.2.4.tar.gz pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.2.4.tar.gz
+scp cl-utilities-1.2.4.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.2.4.tar.gz.asc
+scp cl-utilities-latest.tar.gz pscott at common-lisp.net:/project/cl-utilities/ftp/cl-utilities-1.2.4.tar.gz
+scp cl-utilities-latest.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/ftp/cl-utilities-1.2.4.tar.gz.asc
+scp cl-utilities-latest.tar.gz pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-latest.tar.gz
+scp cl-utilities-latest.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-latest.tar.gz.asc
Added: dependencies/trunk/cl-utilities-1.2.4/read-delimited.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/read-delimited.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,78 @@
+(in-package :cl-utilities)
+
+(defun read-delimited (sequence stream &key (start 0) end
+ (delimiter #\Newline) (test #'eql) (key #'identity))
+ ;; Check bounds on SEQUENCE
+ (multiple-value-setq (start end)
+ (%read-delimited-bounds-check sequence start end))
+ ;; Loop until we run out of input characters or places to put them,
+ ;; or until we encounter the delimiter.
+ (loop for index from start
+ for char = (read-char stream nil nil)
+ for test-result = (funcall test (funcall key char) delimiter)
+ while (and char
+ (< index end)
+ (not test-result))
+ do (setf (elt sequence index) char)
+ finally (return-from read-delimited
+ (values index test-result))))
+
+;; Conditions
+;;;;;;;;;;;;;
+
+(define-condition read-delimited-bounds-error (error)
+ ((start :initarg :start :reader read-delimited-bounds-error-start)
+ (end :initarg :end :reader read-delimited-bounds-error-end)
+ (sequence :initarg :sequence :reader read-delimited-bounds-error-sequence))
+ (:report (lambda (condition stream)
+ (with-slots (start end sequence) condition
+ (format stream "The bounding indices ~S and ~S are bad for a sequence of length ~S"
+ start end (length sequence)))))
+ (:documentation "There's a problem with the indices START and END
+for SEQUENCE. See CLHS SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR issue."))
+
+;; Error checking for bounds
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun %read-delimited-bounds-check (sequence start end)
+ "Check to make sure START and END are in bounds when calling
+READ-DELIMITED with SEQUENCE"
+ (check-type start (or integer null))
+ (check-type end (or integer null))
+ (let ((start (%read-delimited-bounds-check-start sequence start end))
+ (end (%read-delimited-bounds-check-end sequence start end)))
+ ;; Returns (values start end)
+ (%read-delimited-bounds-check-order sequence start end)))
+
+(defun %read-delimited-bounds-check-order (sequence start end)
+ "Check the order of START and END bounds, and return them in the
+correct order."
+ (when (< end start)
+ (restart-case (error 'read-delimited-bounds-error
+ :start start :end end :sequence sequence)
+ (continue ()
+ :report "Switch start and end"
+ (rotatef start end))))
+ (values start end))
+
+(defun %read-delimited-bounds-check-start (sequence start end)
+ "Check to make sure START is in bounds when calling READ-DELIMITED
+with SEQUENCE"
+ (when (and start (< start 0))
+ (restart-case (error 'read-delimited-bounds-error
+ :start start :end end :sequence sequence)
+ (continue ()
+ :report "Use default for START instead"
+ (setf start 0))))
+ start)
+
+(defun %read-delimited-bounds-check-end (sequence start end)
+ "Check to make sure END is in bounds when calling READ-DELIMITED
+with SEQUENCE"
+ (when (and end (> end (length sequence)))
+ (restart-case (error 'read-delimited-bounds-error
+ :start start :end end :sequence sequence)
+ (continue ()
+ :report "Use default for END instead"
+ (setf end nil))))
+ (or end (length sequence)))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/rotate-byte.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/rotate-byte.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,29 @@
+(in-package :cl-utilities)
+
+(defun rotate-byte (count bytespec integer)
+ "Rotates a field of bits within INTEGER; specifically, returns an
+integer that contains the bits of INTEGER rotated COUNT times
+leftwards within the byte specified by BYTESPEC, and elsewhere
+contains the bits of INTEGER. See http://www.cliki.net/ROTATE-BYTE"
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ #-sbcl
+ (let ((size (byte-size bytespec)))
+ (when (= size 0)
+ (return-from rotate-byte integer))
+ (let ((count (mod count size)))
+ (labels ((rotate-byte-from-0 (count size integer)
+ (let ((bytespec (byte size 0)))
+ (if (> count 0)
+ (logior (ldb bytespec (ash integer count))
+ (ldb bytespec (ash integer (- count size))))
+ (logior (ldb bytespec (ash integer count))
+ (ldb bytespec (ash integer (+ count size))))))))
+ (dpb (rotate-byte-from-0 count size (ldb bytespec integer))
+ bytespec
+ integer))))
+ ;; On SBCL, we use the SB-ROTATE-BYTE extension.
+ #+sbcl-uses-sb-rotate-byte (sb-rotate-byte:rotate-byte count bytespec integer))
+
+;; If we're using the SB-ROTATE-BYTE extension, we should inline our
+;; call and let SBCL handle optimization from there.
+#+sbcl-uses-sb-rotate-byte (declaim (inline rotate-byte))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/split-sequence.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/split-sequence.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,244 @@
+;;;; SPLIT-SEQUENCE
+;;;
+;;; This code was based on Arthur Lemmens' in
+;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>;
+;;;
+;;; changes include:
+;;;
+;;; * altering the behaviour of the :from-end keyword argument to
+;;; return the subsequences in original order, for consistency with
+;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only
+;;; affects the answer if :count is less than the number of
+;;; subsequences, by analogy with the above-referenced functions).
+;;;
+;;; * changing the :maximum keyword argument to :count, by analogy
+;;; with CL:REMOVE, CL:SUBSTITUTE, and so on.
+;;;
+;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather
+;;; than SPLIT.
+;;;
+;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT.
+;;;
+;;; * The second return value is now an index rather than a copy of a
+;;; portion of the sequence; this index is the `right' one to feed to
+;;; CL:SUBSEQ for continued processing.
+
+;;; There's a certain amount of code duplication here, which is kept
+;;; to illustrate the relationship between the SPLIT-SEQUENCE
+;;; functions and the CL:POSITION functions.
+
+;;; Examples:
+;;;
+;;; * (split-sequence #\; "a;;b;c")
+;;; -> ("a" "" "b" "c"), 6
+;;;
+;;; * (split-sequence #\; "a;;b;c" :from-end t)
+;;; -> ("a" "" "b" "c"), 0
+;;;
+;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1)
+;;; -> ("c"), 4
+;;;
+;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t)
+;;; -> ("a" "b" "c"), 6
+;;;
+;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra")
+;;; -> ("" "" "r" "c" "d" "" "r" ""), 11
+;;;
+;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra")
+;;; -> ("ab" "a" "a" "ab" "a"), 11
+;;;
+;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9)
+;;; -> ("oo" "bar" "b"), 9
+
+;; cl-utilities note: the license of this file is unclear, and I don't
+;; even know whom to contact to clarify it. If anybody objects to my
+;; assumption that it is public domain, please contact me so I can do
+;; something about it. Previously I required the split-sequence
+ ; package as a dependency, but that was so unwieldy that it was *the*
+;; sore spot sticking out in the design of cl-utilities. -Peter Scott
+
+(in-package :cl-utilities)
+
+(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by delimiter.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE. In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+ (let ((len (length seq))
+ (other-keys (nconc (when test-supplied
+ (list :test test))
+ (when test-not-supplied
+ (list :test-not test-not))
+ (when key-supplied
+ (list :key key)))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position delimiter seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position delimiter seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by items satisfying
+predicate.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE-IF. In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+ (let ((len (length seq))
+ (other-keys (when key-supplied
+ (list :key key))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position-if predicate seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position-if predicate seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by items satisfying
+(CL:COMPLEMENT predicate).
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular,
+the behaviour of :from-end is possibly different from other versions
+of this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped." ; Emacs syntax highlighting is broken, and this helps: "
+ (let ((len (length seq))
+ (other-keys (when key-supplied
+ (list :key key))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position-if-not predicate seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position-if-not predicate seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+;;; clean deprecation
+
+(defun partition (&rest args)
+ (apply #'split-sequence args))
+
+(defun partition-if (&rest args)
+ (apply #'split-sequence-if args))
+
+(defun partition-if-not (&rest args)
+ (apply #'split-sequence-if-not args))
+
+(define-compiler-macro partition (&whole form &rest args)
+ (declare (ignore args))
+ (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.")
+ form)
+
+(define-compiler-macro partition-if (&whole form &rest args)
+ (declare (ignore args))
+ (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.")
+ form)
+
+(define-compiler-macro partition-if-not (&whole form &rest args)
+ (declare (ignore args))
+ (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead")
+ form)
+
+(pushnew :split-sequence *features*)
Added: dependencies/trunk/cl-utilities-1.2.4/test.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/test.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,178 @@
+;; This file requires the FiveAM unit testing framework.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (asdf:oos 'asdf:load-op :fiveam)
+ (asdf:oos 'asdf:load-op :cl-utilities))
+
+;; To run all the tests:
+;; (5am:run! 'cl-utilities-tests::cl-utilities-suite)
+
+(defpackage :cl-utilities-tests
+ (:use :common-lisp :cl-utilities :5am))
+
+(in-package :cl-utilities-tests)
+
+(def-suite cl-utilities-suite :description "Test suite for cl-utilities")
+(in-suite cl-utilities-suite)
+
+;; These tests were taken directly from the comments at the top of
+;; split-sequence.lisp
+(test split-sequence
+ (is (tree-equal (values (split-sequence #\; "a;;b;c"))
+ '("a" "" "b" "c") :test #'equal))
+ (is (tree-equal (values (split-sequence #\; "a;;b;c" :from-end t))
+ '("a" "" "b" "c") :test #'equal))
+ (is (tree-equal (values (split-sequence #\; "a;;b;c" :from-end t :count 1))
+ '("c") :test #'equal))
+ (is (tree-equal (values (split-sequence #\; "a;;b;c" :remove-empty-subseqs t))
+ '("a" "b" "c") :test #'equal))
+ (is (tree-equal (values (split-sequence-if (lambda (x)
+ (member x '(#\a #\b)))
+ "abracadabra"))
+ '("" "" "r" "c" "d" "" "r" "") :test #'equal))
+ (is (tree-equal (values (split-sequence-if-not (lambda (x)
+ (member x '(#\a #\b)))
+ "abracadabra"))
+ '("ab" "a" "a" "ab" "a") :test #'equal))
+ (is (tree-equal (values (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9))
+ '("oo" "bar" "b") :test #'equal)))
+
+(test extremum
+ (is (= (extremum '(1 23 3 4 5 0) #'< :start 1 :end 4) 3))
+ (signals no-extremum (extremum '() #'<))
+ (is-false (handler-bind ((no-extremum #'continue))
+ (extremum '() #'<)))
+ (is (= (extremum '(2/3 2 3 4) #'> :key (lambda (x) (/ 1 x))) 2/3))
+ (is (= (locally (declare (optimize (speed 3) (safety 0)))
+ (extremum #(1 23 3 4 5 0) #'>))
+ 23))
+ (is (= (extremum-fastkey '(2/3 2 3 4) #'> :key (lambda (x) (/ 1 x))) 2/3)))
+
+(test extrema
+ (is (tree-equal (extrema '(3 2 1 1 2 1) #'<)
+ '(1 1 1)))
+ (is (tree-equal (extrema #(3 2 1 1 2 1) #'<)
+ '(1 1 1)))
+ (is (tree-equal (extrema #(3 2 1 1 2 1) #'< :end 4)
+ '(1 1)))
+ (is (tree-equal (extrema '(3 2 1 1 2 1) #'< :end 4)
+ '(1 1)))
+ (is (tree-equal (extrema #(3 2 1 1 2 1) #'< :start 3 :end 4)
+ '(1)))
+ (is (tree-equal (extrema '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr)
+ '((B . 1) (D . 1)))))
+
+(defmacro quietly (&body body)
+ "Perform BODY quietly, muffling any warnings that may arise"
+ `(handler-bind ((warning #'muffle-warning))
+ , at body))
+
+(test n-most-extreme
+ (is (tree-equal (n-most-extreme 1 '(3 1 2 1) #'>)
+ '(3)))
+ (is (tree-equal (n-most-extreme 2 '(3 1 2 1) #'>)
+ '(3 2)))
+ (is (tree-equal (n-most-extreme 2 '(3 1 2 1) #'<)
+ '(1 1)))
+ (is (tree-equal (n-most-extreme 1 '((A . 3) (B . 1) (C . 2) (D . 1)) #'> :key #'cdr)
+ '((A . 3))))
+ (is (tree-equal (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr)
+ '((B . 1) (D . 1))))
+ (is (tree-equal (quietly (n-most-extreme 20 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr))
+ '((B . 1) (D . 1) (C . 2) (A . 3))))
+ (is (tree-equal (quietly (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr :start 1 :end 2))
+ '((B . 1))))
+ (signals n-most-extreme-not-enough-elements (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr :start 1 :end 2)))
+
+(defun delimited-test (&key (delimiter #\|) (start 0) end
+ (string "foogo|ogreogrjejgierjijri|bar|baz"))
+ (with-input-from-string (str string)
+ (let ((buffer (copy-seq " ")))
+ (multiple-value-bind (position delimited-p)
+ (read-delimited buffer str
+ :delimiter delimiter :start start :end end)
+ (declare (ignore delimited-p))
+ (subseq buffer 0 position)))))
+
+(test read-delimited
+ (is (string= (delimited-test) "foogo"))
+ (is (string= (delimited-test :delimiter #\t) "foogo|ogreog"))
+ (is (string= (delimited-test :delimiter #\t :start 3) " foogo|ogr"))
+ (is (string= (delimited-test :start 3) " foogo"))
+ (is (string= (delimited-test :end 3) "foo"))
+ (is (string= (delimited-test :start 1 :end 3) " fo"))
+ (is (string= (delimited-test :string "Hello") "Hello"))
+ (is (string= (delimited-test :string "Hello" :start 3) " Hello"))
+ (is (string= (handler-bind ((read-delimited-bounds-error #'continue))
+ (delimited-test :start 3 :end 1))
+ " fo"))
+ (signals type-error (delimited-test :start 3/2))
+ (signals read-delimited-bounds-error (delimited-test :start -3))
+ (signals read-delimited-bounds-error (delimited-test :end 30))
+ (signals read-delimited-bounds-error (delimited-test :start 3 :end 1)))
+
+;; Random testing would probably work better here.
+(test expt-mod
+ (is (= (expt-mod 2 34 54) (mod (expt 2 34) 54)))
+ (is (= (expt-mod 20 3 54) (mod (expt 20 3) 54)))
+ (is (= (expt-mod 2.5 3.8 34.9) (mod (expt 2.5 3.8) 34.9)))
+ (is (= (expt-mod 2/5 3/8 34/9) (mod (expt 2/5 3/8) 34/9))))
+
+(test collecting
+ (is (tree-equal (collecting (dotimes (x 10) (collect x)))
+ '(0 1 2 3 4 5 6 7 8 9)))
+ (is (tree-equal (collecting
+ (labels ((collect-it (x) (collect x)))
+ (mapcar #'collect-it (reverse '(c b a)))))
+ '(a b c)))
+ (is (tree-equal (multiple-value-bind (a b)
+ (with-collectors (x y)
+ (x 1)
+ (y 2)
+ (x 3))
+ (append a b))
+ '(1 3 2))))
+
+(test with-unique-names
+ (is (equalp (subseq (with-unique-names (foo)
+ (string foo))
+ 0 3)
+ "foo"))
+ (is (equalp (subseq (with-unique-names ((foo "bar"))
+ (string foo))
+ 0 3)
+ "bar"))
+ (is (equalp (subseq (with-unique-names ((foo baz))
+ (string foo))
+ 0 3)
+ "baz"))
+ (is (equalp (subseq (with-unique-names ((foo #\y))
+ (string foo))
+ 0 1)
+ "y"))
+ (is (equalp (subseq (with-gensyms (foo)
+ (string foo))
+ 0 3)
+ "foo")))
+
+;; Taken from spec
+(test rotate-byte
+ (is (= (rotate-byte 3 (byte 32 0) 3) 24))
+ (is (= (rotate-byte 3 (byte 5 5) 3) 3))
+ (is (= (rotate-byte 6 (byte 8 0) -3) -129)))
+
+(test copy-array
+ (let ((test-array (make-array '(10 10) :initial-element 5)))
+ (is (not (eq (copy-array test-array) test-array)))
+ (is (equalp (copy-array test-array) test-array))))
+
+(test compose
+ (labels ((2* (x) (* 2 x)))
+ (is (= (funcall (compose #'1+ #'1+) 1) 3))
+ (is (= (funcall (compose '1+ #'2*) 5) 11))
+ (is (= (funcall (compose #'1+ #'2* '1+) 6) 15))
+ ;; This should signal an undefined function error, since we're
+ ;; using '2* rather than #'2*, which means that COMPOSE will use
+ ;; the dynamic binding at the time it is called rather than the
+ ;; lexical binding here.
+ (signals undefined-function
+ (= (funcall (compose #'1+ '2* '1+) 6) 15))))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/with-unique-names.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/with-unique-names.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,46 @@
+(in-package :cl-utilities)
+
+;; Defined at http://www.cliki.net/WITH-UNIQUE-NAMES
+
+(defmacro with-unique-names ((&rest bindings) &body body)
+ "Executes a series of forms with each var bound to a fresh,
+uninterned symbol. See http://www.cliki.net/WITH-UNIQUE-NAMES"
+ `(let ,(mapcar #'(lambda (binding)
+ (multiple-value-bind (var prefix)
+ (%with-unique-names-binding-parts binding)
+ (check-type var symbol)
+ `(,var (gensym ,(format nil "~A"
+ (or prefix var))))))
+ bindings)
+ , at body))
+
+(defun %with-unique-names-binding-parts (binding)
+ "Return (values var prefix) from a WITH-UNIQUE-NAMES binding
+form. If PREFIX is not given in the binding, NIL is returned to
+indicate that the default should be used."
+ (if (consp binding)
+ (values (first binding) (second binding))
+ (values binding nil)))
+
+(define-condition list-binding-not-supported (warning)
+ ((binding :initarg :binding :reader list-binding-not-supported-binding))
+ (:report (lambda (condition stream)
+ (format stream "List binding ~S not supported by WITH-GENSYMS.
+It will work, but you should use WITH-UNIQUE-NAMES instead."
+ (list-binding-not-supported-binding condition))))
+ (:documentation "List bindings aren't supported by WITH-GENSYMS, and
+if you want to use them you should use WITH-UNIQUE-NAMES instead. That
+said, they will work; they'll just signal this warning to complain
+about it."))
+
+
+(defmacro with-gensyms ((&rest bindings) &body body)
+ "Synonym for WITH-UNIQUE-NAMES, but BINDINGS should only consist of
+atoms; lists are not supported. If you try to give list bindings, a
+LIST-BINDING-NOT-SUPPORTED warning will be signalled, but it will work
+the same way as WITH-UNIQUE-NAMES. Don't do it, though."
+ ;; Signal a warning for each list binding, if there are any
+ (dolist (binding (remove-if-not #'listp bindings))
+ (warn 'list-binding-not-supported :binding binding))
+ ;; Otherwise, this is a synonym for WITH-UNIQUE-NAMES
+ `(with-unique-names ,bindings , at body))
\ No newline at end of file
Added: dependencies/trunk/commons-logging.jar
==============================================================================
Binary file. No diff available.
Added: dependencies/trunk/miglayout-3.7.1.jar
==============================================================================
Binary file. No diff available.
Added: dependencies/trunk/named-readtables/LICENSE
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/LICENSE Tue Jan 26 15:20:07 2010
@@ -0,0 +1,36 @@
+
+Copyright (c) 2007 - 2009 Tobias C. Rittweiler <tcr at freebits.de>
+Copyright (c) 2007, Robert P. Goldman <rpgoldman at sift.info> and SIFT, LLC
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the names of Tobias C. Rittweiler, Robert P. Goldman,
+ SIFT, LLC nor the names of its contributors may be used to
+ endorse or promote products derived from this software without
+ specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY Tobias C. Rittweiler, Robert
+P. Goldman and SIFT, LLC ``AS IS'' AND ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL Tobias C. Rittweiler, Robert
+P. Goldman or SIFT, LLC BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
+EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: dependencies/trunk/named-readtables/cruft.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/cruft.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,375 @@
+;;;;
+;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler <tcr at freebits.de>
+;;;;
+;;;; All rights reserved.
+;;;;
+;;;; See LICENSE for details.
+;;;;
+
+(in-package :editor-hints.named-readtables)
+
+(defmacro define-cruft (name lambda-list &body (docstring . alternatives))
+ (assert (typep docstring 'string) (docstring) "Docstring missing!")
+ (assert (not (null alternatives)))
+ `(progn
+ (declaim (inline ,name))
+ (defun ,name ,lambda-list ,docstring ,(first alternatives))))
+
+(eval-when (:compile-toplevel :execute)
+ #+sbcl (when (find-symbol "ASSERT-NOT-STANDARD-READTABLE"
+ (find-package "SB-IMPL"))
+ (pushnew :sbcl+safe-standard-readtable *features*)))
+
+
+;;;;; Implementation-dependent cruft
+
+;;;; Mapping between a readtable object and its readtable-name.
+
+(defvar *readtable-names* (make-hash-table :test 'eq))
+
+(define-cruft %associate-readtable-with-name (name readtable)
+ "Associate READTABLE with NAME for READTABLE-NAME to work."
+ #+ :common-lisp (setf (gethash readtable *readtable-names*) name))
+
+(define-cruft %unassociate-readtable-from-name (name readtable)
+ "Remove the association between READTABLE and NAME."
+ #+ :common-lisp (progn (assert (eq name (gethash readtable *readtable-names*)))
+ (remhash readtable *readtable-names*)))
+
+(define-cruft %readtable-name (readtable)
+ "Return the name associated with READTABLE."
+ #+ :common-lisp (values (gethash readtable *readtable-names*)))
+
+(define-cruft %list-all-readtable-names ()
+ "Return a list of all available readtable names."
+ #+ :common-lisp (list* :standard :current
+ (loop for name being each hash-value of *readtable-names*
+ collect name)))
+
+
+;;;; Mapping between a readtable-name and the actual readtable object.
+
+;;; On Allegro we reuse their named-readtable support so we work
+;;; nicely on their infrastructure.
+
+#-allegro
+(defvar *named-readtables* (make-hash-table :test 'eq))
+
+#+allegro
+(defun readtable-name-for-allegro (symbol)
+ (multiple-value-bind (kwd status)
+ (if (keywordp symbol)
+ (values symbol nil)
+ ;; Kludge: ACL uses keywords to name readtables, we allow
+ ;; arbitrary symbols.
+ (intern (format nil "~A.~A"
+ (package-name (symbol-package symbol))
+ (symbol-name symbol))
+ :keyword))
+ (prog1 kwd
+ (assert (or (not status) (get kwd 'named-readtable-designator)))
+ (setf (get kwd 'named-readtable-designator) t))))
+
+(define-cruft %associate-name-with-readtable (name readtable)
+ "Associate NAME with READTABLE for FIND-READTABLE to work."
+ #+ :allegro (setf (excl:named-readtable (readtable-name-for-allegro name)) readtable)
+ #+ :common-lisp (setf (gethash name *named-readtables*) readtable))
+
+(define-cruft %unassociate-name-from-readtable (name readtable)
+ "Remove the association between NAME and READTABLE"
+ #+ :allegro (let ((n (readtable-name-for-allegro name)))
+ (assert (eq readtable (excl:named-readtable n)))
+ (setf (excl:named-readtable n) nil))
+ #+ :common-lisp (progn (assert (eq readtable (gethash name *named-readtables*)))
+ (remhash name *named-readtables*)))
+
+(define-cruft %find-readtable (name)
+ "Return the readtable named NAME."
+ #+ :allegro (excl:named-readtable (readtable-name-for-allegro name))
+ #+ :common-lisp (values (gethash name *named-readtables* nil)))
+
+
+;;;; Reader-macro related predicates
+
+;;; CLISP creates new function objects for standard reader macros on
+;;; each readtable copy.
+(define-cruft function= (fn1 fn2)
+ "Are reader-macro function-designators FN1 and FN2 the same?"
+ #+ :clisp
+ (let* ((fn1 (ensure-function fn1))
+ (fn2 (ensure-function fn2))
+ (n1 (system::function-name fn1))
+ (n2 (system::function-name fn2)))
+ (if (and (eq n1 :lambda) (eq n2 :lambda))
+ (eq fn1 fn2)
+ (equal n1 n2)))
+ #+ :common-lisp
+ (eq (ensure-function fn1) (ensure-function fn2)))
+
+;;; CCL has a bug that prevents the portable form below from working
+;;; (Ticket 601). CLISP will incorrectly fold the call to G-D-M-C away
+;;; if not declared inline.
+(define-cruft dispatch-macro-char-p (char rt)
+ "Is CHAR a dispatch macro character in RT?"
+ #+ :ccl
+ (let ((def (cdr (nth-value 1 (ccl::%get-readtable-char char rt)))))
+ (or (consp (cdr def))
+ (eq (car def) #'ccl::read-dispatch)))
+ #+ :common-lisp
+ (handler-case (locally
+ #+clisp (declare (notinline get-dispatch-macro-character))
+ (get-dispatch-macro-character char #\x rt)
+ t)
+ (error () nil)))
+
+;; (defun macro-char-p (char rt)
+;; (let ((reader-fn (%get-macro-character char rt)))
+;; (and reader-fn t)))
+
+;; (defun standard-macro-char-p (char rt)
+;; (multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt)
+;; (multiple-value-bind (std-fn std-flag) (get-macro-character char *standard-readtable*)
+;; (and (eq rt-fn std-fn)
+;; (eq rt-flag std-flag)))))
+
+;; (defun standard-dispatch-macro-char-p (disp-char sub-char rt)
+;; (flet ((non-terminating-p (ch rt) (nth-value 1 (get-macro-character ch rt))))
+;; (and (eq (non-terminating-p disp-char rt)
+;; (non-terminating-p disp-char *standard-readtable*))
+;; (eq (get-dispatch-macro-character disp-char sub-char rt)
+;; (get-dispatch-macro-character disp-char sub-char *standard-readtable*)))))
+
+
+;;;; Readtables Iterators
+
+(defmacro with-readtable-iterator ((name readtable) &body body)
+ (let ((it (gensym)))
+ `(let ((,it (%make-readtable-iterator ,readtable)))
+ (macrolet ((,name () `(funcall ,',it)))
+ , at body))))
+
+#+sbcl
+(defun %make-readtable-iterator (readtable)
+ (let ((char-macro-array (sb-impl::character-macro-array readtable))
+ (char-macro-ht (sb-impl::character-macro-hash-table readtable))
+ (dispatch-tables (sb-impl::dispatch-tables readtable))
+ (char-code 0))
+ (with-hash-table-iterator (ht-iterator char-macro-ht)
+ (labels ((grovel-base-chars ()
+ (declare (optimize sb-c::merge-tail-calls))
+ (if (>= char-code sb-int:base-char-code-limit)
+ (grovel-unicode-chars)
+ (let ((reader-fn (svref char-macro-array char-code))
+ (char (code-char (shiftf char-code (1+ char-code)))))
+ (if reader-fn
+ (yield char reader-fn)
+ (grovel-base-chars)))))
+ (grovel-unicode-chars ()
+ (multiple-value-bind (more? char reader-fn) (ht-iterator)
+ (if (not more?)
+ (values nil nil nil nil nil)
+ (yield char reader-fn))))
+ (yield (char reader-fn)
+ (let ((disp-ht))
+ (cond
+ ((setq disp-ht (cdr (assoc char dispatch-tables)))
+ (let* ((disp-fn (get-macro-character char readtable))
+ (sub-char-alist))
+ (maphash (lambda (k v)
+ (push (cons k v) sub-char-alist))
+ disp-ht)
+ (values t char disp-fn t sub-char-alist)))
+ (t
+ (values t char reader-fn nil nil))))))
+ #'grovel-base-chars))))
+
+#+clozure
+(defun %make-readtable-iterator (readtable)
+ (let ((char-macro-alist (ccl::rdtab.alist readtable)))
+ (lambda ()
+ (if char-macro-alist
+ (destructuring-bind (char . defn) (pop char-macro-alist)
+ (if (consp defn)
+ (values t char (car defn) t (cdr defn))
+ (values t char defn nil nil)))
+ (values nil nil nil nil nil)))))
+
+;;; Written on ACL 8.0.
+#+allegro
+(defun %make-readtable-iterator (readtable)
+ (declare (optimize speed)) ; for TCO
+ (check-type readtable readtable)
+ (let* ((macro-table (first (excl::readtable-macro-table readtable)))
+ (dispatch-tables (excl::readtable-dispatch-tables readtable))
+ (table-length (length macro-table))
+ (idx 0))
+ (labels ((grovel-macro-chars ()
+ (if (>= idx table-length)
+ (grovel-dispatch-chars)
+ (let ((read-fn (svref macro-table idx))
+ (oidx idx))
+ (incf idx)
+ (if (or (eq read-fn #'excl::read-token)
+ (eq read-fn #'excl::read-dispatch-char)
+ (eq read-fn #'excl::undefined-macro-char))
+ (grovel-macro-chars)
+ (values t (code-char oidx) read-fn nil nil)))))
+ (grovel-dispatch-chars ()
+ (if (null dispatch-tables)
+ (values nil nil nil nil nil)
+ (destructuring-bind (disp-char sub-char-table)
+ (first dispatch-tables)
+ (setf dispatch-tables (rest dispatch-tables))
+ ;;; Kludge. We can't fully clear dispatch tables
+ ;;; in %CLEAR-READTABLE.
+ (when (eq (svref macro-table (char-code disp-char))
+ #'excl::read-dispatch-char)
+ (values t
+ disp-char
+ (svref macro-table (char-code disp-char))
+ t
+ (loop for subch-fn across sub-char-table
+ for subch-code from 0
+ when subch-fn
+ collect (cons (code-char subch-code)
+ subch-fn))))))))
+ #'grovel-macro-chars)))
+
+
+#-(or sbcl clozure allegro)
+(eval-when (:compile-toplevel)
+ (let ((*print-pretty* t))
+ (simple-style-warn
+ "~&~@< ~@;~A has not been ported to ~A. ~
+ We fall back to a portable implementation of readtable iterators. ~
+ This implementation has to grovel through all available characters. ~
+ On Unicode-aware implementations this may come with some costs.~@:>"
+ (package-name '#.*package*) (lisp-implementation-type))))
+
+#-(or sbcl clozure allegro)
+(defun %make-readtable-iterator (readtable)
+ (check-type readtable readtable)
+ (let ((char-code 0))
+ #'(lambda ()
+ (prog ()
+ :GROVEL
+ (when (< char-code char-code-limit)
+ (let* ((char (code-char char-code))
+ (fn (get-macro-character char readtable)))
+ (incf char-code)
+ (when (not fn) (go :GROVEL))
+ (multiple-value-bind (disp? alist)
+ (handler-case ; grovel dispatch macro characters.
+ (values t
+ ;; Only grovel upper case characters to
+ ;; avoid duplicates.
+ (loop for code from 0 below char-code-limit
+ for subchar = (let ((ch (code-char code)))
+ (when (or (not (alpha-char-p ch))
+ (upper-case-p ch))
+ ch))
+ for disp-fn = (and subchar
+ (get-dispatch-macro-character
+ char subchar readtable))
+ when disp-fn
+ collect (cons subchar disp-fn)))
+ (error () nil))
+ (return (values t char fn disp? alist)))))))))
+
+(defmacro do-readtable ((entry-designator readtable &optional result)
+ &body body)
+ "Iterate through a readtable's macro characters, and dispatch macro characters."
+ (destructuring-bind (char &optional reader-fn non-terminating-p disp? table)
+ (if (symbolp entry-designator)
+ (list entry-designator)
+ entry-designator)
+ (let ((iter (gensym "ITER+"))
+ (more? (gensym "MORE?+"))
+ (rt (gensym "READTABLE+")))
+ `(let ((,rt ,readtable))
+ (with-readtable-iterator (,iter ,rt)
+ (loop
+ (multiple-value-bind (,more?
+ ,char
+ ,@(when reader-fn (list reader-fn))
+ ,@(when disp? (list disp?))
+ ,@(when table (list table)))
+ (,iter)
+ (unless ,more? (return ,result))
+ (let ,(when non-terminating-p
+ ;; FIXME: N-T-P should be incorporated in iterators.
+ `((,non-terminating-p
+ (nth-value 1 (get-macro-character ,char ,rt)))))
+ , at body))))))))
+
+;;;; Misc
+
+;;; This should return an implementation's actual standard readtable
+;;; object only if the implementation makes the effort to guard against
+;;; modification of that object. Otherwise it should better return a
+;;; copy.
+(define-cruft %standard-readtable ()
+ "Return the standard readtable."
+ #+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable*
+ #+ :common-lisp (copy-readtable nil))
+
+;;; On SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
+;;; readtable's dispatch table properly.
+;;; Same goes for Allegro but that does not seem to provide a
+;;; setter for their readtable's dispatch tables. Hence this ugly
+;;; workaround.
+(define-cruft %clear-readtable (readtable)
+ "Make all macro characters in READTABLE be constituents."
+ #+ :sbcl
+ (prog1 readtable
+ (do-readtable (char readtable)
+ (set-syntax-from-char char #\A readtable))
+ (setf (sb-impl::dispatch-tables readtable) nil))
+ #+ :allegro
+ (prog1 readtable
+ (do-readtable (char readtable)
+ (set-syntax-from-char char #\A readtable))
+ (let ((dispatch-tables (excl::readtable-dispatch-tables readtable)))
+ (setf (cdr dispatch-tables) nil)
+ (setf (caar dispatch-tables) #\Backspace)
+ (setf (cadar dispatch-tables) (fill (cadar dispatch-tables) nil))))
+ #+ :common-lisp
+ (do-readtable (char readtable readtable)
+ (set-syntax-from-char char #\A readtable)))
+
+;;; See Clozure Trac Ticket 601. This is supposed to be removed at
+;;; some point in the future.
+(define-cruft %get-dispatch-macro-character (char subchar rt)
+ "Ensure ANSI behaviour for GET-DISPATCH-MACRO-CHARACTER."
+ #+ :ccl (ignore-errors
+ (get-dispatch-macro-character char subchar rt))
+ #+ :common-lisp (get-dispatch-macro-character char subchar rt))
+
+;;; Allegro stores READ-TOKEN as reader macro function of each
+;;; constituent character.
+(define-cruft %get-macro-character (char rt)
+ "Ensure ANSI behaviour for GET-MACRO-CHARACTER."
+ #+ :allegro (let ((fn (get-macro-character char rt)))
+ (cond ((not fn) nil)
+ ((function= fn #'excl::read-token) nil)
+ (t fn)))
+ #+ :common-lisp (get-macro-character char rt))
+
+
+;;;; Specialized PRINT-OBJECT for named readtables.
+
+;;; As per #19 in CLHS 11.1.2.1.2 defining a method for PRINT-OBJECT
+;;; that specializes on READTABLE is actually forbidden. It's quite
+;;; likely to work (modulo package-locks) on most implementations,
+;;; though.
+
+;;; We don't need this on Allegro CL's as we hook into their
+;;; named-readtable facility, and they provide such a method already.
+#-allegro
+(without-package-lock (:common-lisp)
+ (defmethod print-object :around ((rt readtable) stream)
+ (let ((name (readtable-name rt)))
+ (if name
+ (print-unreadable-object (rt stream :type nil :identity t)
+ (format stream "~A ~S" :named-readtable name))
+ (call-next-method)))))
\ No newline at end of file
Added: dependencies/trunk/named-readtables/define-api.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/define-api.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,63 @@
+
+(in-package :named-readtables)
+
+(defmacro define-api (name lambda-list type-list &body body)
+ (flet ((parse-type-list (type-list)
+ (let ((pos (position '=> type-list)))
+ (assert pos () "You forgot to specify return type (`=>' missing.)")
+ (values (subseq type-list 0 pos)
+ `(values ,@(nthcdr (1+ pos) type-list) &optional)))))
+ (multiple-value-bind (body decls docstring)
+ (parse-body body :documentation t :whole `(define-api ,name))
+ (multiple-value-bind (arg-typespec value-typespec)
+ (parse-type-list type-list)
+ (multiple-value-bind (reqs opts rest keys)
+ (parse-ordinary-lambda-list lambda-list)
+ (declare (ignorable reqs opts rest keys))
+ `(progn
+ (declaim (ftype (function ,arg-typespec ,value-typespec) ,name))
+ (locally
+ ;;; Muffle the annoying "&OPTIONAL and &KEY found in
+ ;;; the same lambda list" style-warning
+ #+sbcl (declare (sb-ext:muffle-conditions style-warning))
+ (defun ,name ,lambda-list
+ ,docstring
+
+ #+sbcl (declare (sb-ext:unmuffle-conditions style-warning))
+
+ , at decls
+
+ ;; SBCL will interpret the ftype declaration as
+ ;; assertion and will insert type checks for us.
+ #-sbcl
+ (progn
+ ;; CHECK-TYPE required parameters
+ ,@(loop for req-arg in reqs
+ for req-type = (pop type-list)
+ do (assert req-type)
+ collect `(check-type ,req-arg ,req-type))
+
+ ;; CHECK-TYPE optional parameters
+ ,@(loop initially (assert (or (null opts)
+ (eq (pop type-list) '&optional)))
+ for (opt-arg . nil) in opts
+ for opt-type = (pop type-list)
+ do (assert opt-type)
+ collect `(check-type ,opt-arg ,opt-type))
+
+ ;; CHECK-TYPE rest parameter
+ ,@(when rest
+ (assert (eq (pop type-list) '&rest))
+ (let ((rest-type (pop type-list)))
+ (assert rest-type)
+ `((dolist (x ,rest)
+ (check-type x ,rest-type)))))
+
+ ;; CHECK-TYPE key parameters
+ ,@(loop initially (assert (or (null keys)
+ (eq (pop type-list) '&key)))
+ for ((keyword key-arg) . nil) in keys
+ for (nil key-type) = (find keyword type-list :key #'car)
+ collect `(check-type ,key-arg ,key-type)))
+
+ , at body))))))))
\ No newline at end of file
Added: dependencies/trunk/named-readtables/doc/named-readtables.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/doc/named-readtables.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,463 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<html>
+
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <title>EDITOR-HINTS.NAMED-READTABLES</title>
+ <style type="text/css">
+ pre { padding:5px; background-color:#e0e0e0 }
+ h3, h4 { text-decoration: underline; }
+ a { text-decoration: none; padding: 1px 2px 1px 2px; }
+ a:visited { text-decoration: none; padding: 1px 2px 1px 2px; }
+ a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; }
+ a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; }
+ a.none { text-decoration: none; padding: 0; }
+ a.none:visited { text-decoration: none; padding: 0; }
+ a.none:hover { text-decoration: none; border: none; padding: 0; }
+ a.none:focus { text-decoration: none; border: none; padding: 0; }
+ a.noborder { text-decoration: none; padding: 0; }
+ a.noborder:visited { text-decoration: none; padding: 0; }
+ a.noborder:hover { text-decoration: none; border: none; padding: 0; }
+ a.noborder:focus { text-decoration: none; border: none; padding: 0; }
+ pre.none { padding:5px; background-color:#ffffff }
+ </style>
+</head>
+
+<body bgcolor=white>
+
+<h2> EDITOR-HINTS.NAMED-READTABLES</h2>
+
+<h5> by Tobias C Rittweiler </h5>
+
+<font color=red>Download:</font> <br> <br>
+
+
+ <code>darcs get http://common-lisp.net/~trittweiler/darcs/editor-hints/named-readtables/</code> (to be changed)
+
+<br> <br><h3><a class=none name="contents">Contents</a></h3>
+<ol>
+ <li> <a href="#what_are_named-readtables?">What are Named-Readtables?</a>
+ <li> <a href="#notes_on_the_api">Notes on the API</a>
+ <li> <a href="#important_api_idiosyncrasies">Important API idiosyncrasies</a>
+ <li> <a href="#preregistered_readtables">Preregistered Readtables</a>
+ <li> <a href="#examples">Examples</a>
+ <li> <a href="#acknowledgements">Acknowledgements</a>
+
+
+ <li><a href="#dictionary">Dictionary</a>
+ <ol>
+ <li><a href="#COPY-NAMED-READTABLE"><code>COPY-NAMED-READTABLE</code></a>
+ <li><a href="#DEFREADTABLE"><code>DEFREADTABLE</code></a>
+ <li><a href="#ENSURE-READTABLE"><code>ENSURE-READTABLE</code></a>
+ <li><a href="#FIND-READTABLE"><code>FIND-READTABLE</code></a>
+ <li><a href="#IN-READTABLE"><code>IN-READTABLE</code></a>
+ <li><a href="#LIST-ALL-NAMED-READTABLES"><code>LIST-ALL-NAMED-READTABLES</code></a>
+ <li><a href="#MAKE-READTABLE"><code>MAKE-READTABLE</code></a>
+ <li><a href="#MERGE-READTABLES-INTO"><code>MERGE-READTABLES-INTO</code></a>
+ <li><a href="#NAMED-READTABLE-DESIGNATOR"><code>NAMED-READTABLE-DESIGNATOR</code></a>
+ <li><a href="#READER-MACRO-CONFLICT"><code>READER-MACRO-CONFLICT</code></a>
+ <li><a href="#READTABLE-DOES-ALREADY-EXIST"><code>READTABLE-DOES-ALREADY-EXIST</code></a>
+ <li><a href="#READTABLE-DOES-NOT-EXIST"><code>READTABLE-DOES-NOT-EXIST</code></a>
+ <li><a href="#READTABLE-NAME"><code>READTABLE-NAME</code></a>
+ <li><a href="#REGISTER-READTABLE"><code>REGISTER-READTABLE</code></a>
+ <li><a href="#RENAME-READTABLE"><code>RENAME-READTABLE</code></a>
+ <li><a href="#UNREGISTER-READTABLE"><code>UNREGISTER-READTABLE</code></a>
+
+ </ol>
+</ol> <br> <br><h3><a class=none name="what_are_named-readtables?">What are Named-Readtables?</a></h3>
+ Named-Readtables is a library that provides a namespace for readtables akin to the <br> already-existing namespace of packages. In particular:
+<ul>
+ <li>you can associate readtables with names, and retrieve readtables by names;</li>
+ <li>you can associate source files with readtable names, and be sure that the <br> right readtable is active when compiling/loading the file;</li>
+ <li>similiarly, your development environment now has a chance to automatically <br> determine what readtable should be active while processing source forms on <br> interactive commands. (E.g. think of `C-c C-c' in Slime [yet to be done])</li>
+</ul>
+ Additionally, it also attempts to become a facility for using readtables in a <br> <u>modular</u> way. In particular:
+<ul>
+ <li>it provides a macro to specify the content of a readtable at a glance;</li>
+ <li>it makes it possible to use multiple inheritance between readtables.</li>
+</ul>
+<br> <br><h3><a class=none name="notes_on_the_api">Notes on the API</a></h3>
+ The <code>API</code> heavily imitates the <code>API</code> of packages. This has the nice property that any <br> experienced Common Lisper will take it up without effort.
+<br><br>
+ <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/m_defpkg.htm"><code>DEFPACKAGE</code></a></code>
+<br><br>
+ <code><a href="#In-Readtable"><code>IN-READTABLE</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/m_in_pkg.htm"><code>IN-PACKAGE</code></a></code>
+<br><br>
+ <code><a href="#Merge-Readtables-Into"><code>MERGE-READTABLES-INTO</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_use_pk.htm"><code>USE-PACKAGE</code></a></code>
+<br><br>
+ <code><a href="#Make-Readtable"><code>MAKE-READTABLE</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_mk_pkg.htm"><code>MAKE-PACKAGE</code></a></code>
+<br><br>
+ <code><a href="#Unregister-Readtable"><code>UNREGISTER-READTABLE</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_del_pk.htm"><code>DELETE-PACKAGE</code></a></code>
+<br><br>
+ <code><a href="#Rename-Readtable"><code>RENAME-READTABLE</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_rn_pkg.htm"><code>RENAME-PACKAGE</code></a></code>
+<br><br>
+ <code><a href="#Find-Readtable"><code>FIND-READTABLE</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_find_p.htm"><code>FIND-PACKAGE</code></a></code>
+<br><br>
+ <code><a href="#Readtable-Name"><code>READTABLE-NAME</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_pkg_na.htm"><code>PACKAGE-NAME</code></a></code>
+<br><br>
+ <code><a href="#List-All-Named-Readtables"><code>LIST-ALL-NAMED-READTABLES</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_list_a.htm"><code>LIST-ALL-PACKAGES</code></a></code>
+<br> <br><h3><a class=none name="important_api_idiosyncrasies">Important API idiosyncrasies</a></h3>
+ There are three major differences between the <code>API</code> of Named-Readtables, and the <code>API</code> <br> of packages.
+<br><br>
+ <code>1.</code> Readtable names are symbols not strings.
+<br><br>
+ Time has shown that the fact that packages are named by strings causes severe <br> headache because of the potential of package names colliding with each other.
+<br><br>
+ Hence, readtables are named by symbols lest to make the situation worse than it <br> already is. Consequently, readtables named <code>CL-ORACLE:SQL-SYNTAX</code> and <br> <code>CL-MYSQL:SQL-SYNTAX</code> can happily coexist next to each other. Or, taken to an extreme, <br> <code>SCHEME:SYNTAX</code> and <code>ELISP:SYNTAX.</code>
+<br><br>
+ If, for example to duly signify the importance of your cool readtable hack, you <br> really think it deserves a global name, you can always resort to keywords.
+<br><br>
+ <code>2.</code> The inheritance is resolved statically, not dynamically.
+<br><br>
+ A package that uses another package will have access to all the other <br> package's exported symbols, even to those that will be added after its <br> definition. I.e. the inheritance is resolved at run-time, that is dynamically.
+<br><br>
+ Unfortunately, we cannot do the same for readtables in a portable manner.
+<br><br>
+ Therefore, we do not talk about "using" another readtable but about <br> "merging" the other readtable's definition into the readtable we are <br> going to define. I.e. the inheritance is resolved once at definition time, that is <br> statically.
+<br><br>
+ (Such merging can more or less be implemented portably albeit at a certain cost. <br> Most of the time, this cost manifests itself at the time a readtable is defined, <br> i.e. once at compile-time, so it may not bother you. Nonetheless, we provide extra <br> support for Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your <br> implementation of choice are welcome, of course.)
+<br><br>
+ <code>3.</code> <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> does not have compile-time effects.
+<br><br>
+ If you define a package via <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/m_defpkg.htm"><code>DEFPACKAGE</code></a>,</code> you can make that package the currently <br> active package for the subsequent compilation of the same file via <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/m_in_pkg.htm"><code>IN-PACKAGE</code></a>.</code> The <br> same is, however, not true for <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> and <code><a href="#In-Readtable"><code>IN-READTABLE</code></a></code> for the following <br> reason:
+<br><br>
+ It's unlikely that the need for special reader-macros arises for a problem <br> which can be solved in just one file. Most often, you're going to define the <br> reader macro functions, and set up the corresponding readtable in an extra file.
+<br><br>
+ If <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> had compile-time effects, you'd have to wrap each definition <br> of a reader-macro function in an <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/s_eval_w.htm"><code>EVAL-WHEN</code></a></code> to make its definition available at <br> compile-time. Because that's simply not the common case, <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> does not <br> have a compile-time effect.
+<br><br>
+ If you want to use a readtable within the same file as its definition, wrap the <br> <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> and the reader-macro function definitions in an explicit <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/s_eval_w.htm"><code>EVAL-WHEN</code></a>.</code>
+<br> <br><h3><a class=none name="preregistered_readtables">Preregistered Readtables</a></h3>
+ - <code>NIL,</code> <code>:STANDARD,</code> and <code>:COMMON-LISP</code> designate the <i><a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#standard_readtable">standard readtable</a></i>.
+<br><br>
+ - <code>:MODERN</code> designates a <u>case-preserving</u> <i><a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#standard-readtable">standard-readtable</a></i>.
+<br><br>
+ - <code>:CURRENT</code> designates the <i><a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#current_readtable">current readtable</a></i>.
+<br> <br><h3><a class=none name="examples">Examples</a></h3>
+<pre>
+ (defreadtable elisp:syntax
+ (:merge :standard)
+ (:macro-char #\? #'elisp::read-character-literal t)
+ (:macro-char #\[ #'elisp::read-vector-literal t)
+ ...
+ (:case :preserve))
+
+ (defreadtable scheme:syntax
+ (:merge :standard)
+ (:macro-char #\[ #'(lambda (stream char)
+ (read-delimited-list #\] stream)))
+ (:macro-char #\# :dispatch)
+ (:dispatch-macro-char #\# #\t #'scheme::read-#t)
+ (:dispatch-macro-char #\# #\f #'scheme::read-#f)
+ ...
+ (:case :preserve))
+
+ (in-readtable elisp:syntax)
+
+ ...
+
+ (in-readtable scheme:syntax)
+
+ ...
+</pre>
+
+<br> <br><h3><a class=none name="acknowledgements">Acknowledgements</a></h3>
+ Thanks to Robert Goldman for making me want to write this library.
+<br><br>
+ Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart Botta, David <br> Crawford, and Pascal Costanza for being early adopters, providing comments and <br> bugfixes.
+<br> <br>
+<br> <br><h3><a class=none name="dictionary">Dictionary</a></h3>
+
+
+<!-- Entry for COPY-NAMED-READTABLE -->
+
+<p><br>[Function]<br><a class=none name='COPY-NAMED-READTABLE'><b>copy-named-readtable</b> <i>named-readtable</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>named-readtable</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>result</i>: <code>READTABLE</code></blockquote> Description:
+<blockquote>
+
+Like <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_cp_rdt.htm"><code>COPY-READTABLE</code></a></code> but takes a <code><a href="#Named-Readtable-Designator"><code>NAMED-READTABLE-DESIGNATOR</code></a></code> as argument.
+
+
+</blockquote>
+
+<!-- End of entry for COPY-NAMED-READTABLE -->
+
+
+<!-- Entry for DEFREADTABLE -->
+
+<p><br>[Macro]<br><a class=none name='DEFREADTABLE'><b>defreadtable</b> <i>name &body options</i> => <i>result</i></a><br><br> Description:
+<blockquote>
+
+Define a new named readtable, whose name is given by the symbol <i>name</i>. Or, if <br> a readtable is already registered under that name, redefine that one.
+<br><br>
+The readtable can be populated using the following <i>options</i>:
+<br><br>
+ <code>(:MERGE</code> <i>readtable-designators</i>+)
+<br><br>
+ Merge the readtables designated into the new readtable being defined as per <br> <code><a href="#Merge-Readtables-Into"><code>MERGE-READTABLES-INTO</code></a>.</code>
+<br><br>
+ If no <code>:MERGE</code> clause is given, an empty readtable is used. See <code><a href="#Make-Readtable"><code>MAKE-READTABLE</code></a>.</code>
+<br><br>
+ <code>(:FUZE</code> <i>readtable-designators</i>+)
+<br><br>
+ Like <code>:MERGE</code> except:
+<br><br>
+ Error conditions of type <code><a href="#Reader-Macro-Conflict"><code>READER-MACRO-CONFLICT</code></a></code> that are signaled during the merge <br> operation will be silently <u>continued</u>. It follows that reader macros in earlier <br> entries will be overwritten by later ones.
+<br><br>
+ <code>(:DISPATCH-MACRO-CHAR</code> <i>macro-char</i> <i>sub-char</i> <i>function</i>)
+<br><br>
+ Define a new sub character <i>sub-char</i> for the dispatching macro character <br> <i>macro-char</i>, per <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_set__1.htm"><code>SET-DISPATCH-MACRO-CHARACTER</code></a>.</code> You probably have to define <br> <i>macro-char</i> as a dispatching macro character by the following option first.
+<br><br>
+ <code>(:MACRO-CHAR</code> <i>macro-char</i> <i>function</i> [<i>non-terminating-p</i>])
+<br><br>
+ Define a new macro character in the readtable, per <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_set_ma.htm"><code>SET-MACRO-CHARACTER</code></a>.</code> If <br> <i>function</i> is the keyword <code>:DISPATCH,</code> <i>macro-char</i> is made a dispatching <br> macro character, per <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_mk_dis.htm"><code>MAKE-DISPATCH-MACRO-CHARACTER</code></a>.</code>
+<br><br>
+ <code>(:SYNTAX-FROM</code> <i>from-readtable-designator</i> <i>from-char</i> <i>to-char</i>)
+<br><br>
+ Set the character syntax of <i>to-char</i> in the readtable being defined to the <br> same syntax as <i>from-char</i> as per <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_set_sy.htm"><code>SET-SYNTAX-FROM-CHAR</code></a>.</code>
+<br><br>
+ <code>(:CASE</code> <i>case-mode</i>)
+<br><br>
+ Defines the <i><a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#case_sensitivity_mode">case sensitivity mode</a></i> of the resulting readtable.
+<br><br>
+Any number of option clauses may appear. The options are grouped by their type, but <br> in each group the order the options appeared textually is preserved. The following <br> groups exist and are executed in the following order: <code>:MERGE</code> and <code>:FUZE</code> (one group), <br> <code>:CASE,</code> <code>:MACRO-CHAR</code> and <code>:DISPATCH-MACRO-CHAR</code> (one group), finally <code>:SYNTAX-FROM.</code>
+<br><br>
+Notes:
+<br><br>
+ The readtable is defined at load-time. If you want to have it available at <br> compilation time <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/a__.htm"><code>-</code></a>-</code> say to use its reader-macros in the same file as its definition <br> <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/a__.htm"><code>-</code></a>-</code> you have to wrap the <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> form in an explicit <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/s_eval_w.htm"><code>EVAL-WHEN</code></a>.</code>
+<br><br>
+ On redefinition, the target readtable is made empty first before it's refilled <br> according to the clauses.
+<br><br>
+ <code>NIL,</code> <code>:STANDARD,</code> <code>:COMMON-LISP,</code> <code>:MODERN,</code> and <code>:CURRENT</code> are preregistered readtable <br> names.
+
+
+</blockquote>
+
+<!-- End of entry for DEFREADTABLE -->
+
+
+<!-- Entry for ENSURE-READTABLE -->
+
+<p><br>[Function]<br><a class=none name='ENSURE-READTABLE'><b>ensure-readtable</b> <i>name <tt>&optional</tt> default</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>name</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>default</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>result</i>: <code>READTABLE</code></blockquote> Description:
+<blockquote>
+
+Looks up the readtable specified by <i>name</i> and returns it if it's found. <br> If it is not found, it registers the readtable designated by <i>default</i> under <br> the name represented by <i>name</i>; or if no default argument is given, it signals <br> an error of type <code><a href="#Readtable-Does-Not-Exist"><code>READTABLE-DOES-NOT-EXIST</code></a></code> instead.
+
+
+</blockquote>
+
+<!-- End of entry for ENSURE-READTABLE -->
+
+
+<!-- Entry for FIND-READTABLE -->
+
+<p><br>[Function]<br><a class=none name='FIND-READTABLE'><b>find-readtable</b> <i>name</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>name</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>result</i>: <code>(OR
+ READTABLE
+ NULL)</code></blockquote> Description:
+<blockquote>
+
+Looks for the readtable specified by <i>name</i> and returns it if it is found. <br> Returns <code>NIL</code> otherwise.
+
+
+</blockquote>
+
+<!-- End of entry for FIND-READTABLE -->
+
+
+<!-- Entry for IN-READTABLE -->
+
+<p><br>[Macro]<br><a class=none name='IN-READTABLE'><b>in-readtable</b> <i>name</i> => <i>result</i></a><br><br> Description:
+<blockquote>
+
+Set <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/v_rdtabl.htm"><code>*READTABLE*</code></a></code> to the readtable referred to by the symbol <i>name</i>.
+
+
+</blockquote>
+
+<!-- End of entry for IN-READTABLE -->
+
+
+<!-- Entry for LIST-ALL-NAMED-READTABLES -->
+
+<p><br>[Function]<br><a class=none name='LIST-ALL-NAMED-READTABLES'><b>list-all-named-readtables</b> <i></i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>result</i>: <code>LIST</code></blockquote> Description:
+<blockquote>
+
+Returns a list of all registered readtables. The returned list is guaranteed to be <br> fresh, but may contain duplicates.
+
+
+</blockquote>
+
+<!-- End of entry for LIST-ALL-NAMED-READTABLES -->
+
+
+<!-- Entry for MAKE-READTABLE -->
+
+<p><br>[Function]<br><a class=none name='MAKE-READTABLE'><b>make-readtable</b> <i><tt>&optional</tt> name <tt>&key</tt> merge</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>name</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>merge</i>: <code>LIST</code></blockquote><blockquote><i>result</i>: <code>READTABLE</code></blockquote> Description:
+<blockquote>
+
+Creates and returns a new readtable under the specified <i>name</i>.
+<br><br>
+<i>merge</i> takes a list of <code><a href="#Named-Readtable-Designators"><code>NAMED-READTABLE-DESIGNATORS</code></a></code> and specifies the <br> readtables the new readtable is created from. (See the <code>:MERGE</code> clause of <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> <br> for details.)
+<br><br>
+If <i>merge</i> is <code>NIL,</code> an empty readtable is used instead.
+<br><br>
+If <i>name</i> is not given, an anonymous empty readtable is returned.
+<br><br>
+Notes:
+<br><br>
+ An empty readtable is a readtable where each character's syntax is the same as <br> in the <i><a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#standard_readtable">standard readtable</a></i> except that each macro character has been made a <br> constituent. Basically: whitespace stays whitespace, everything else is constituent.
+
+
+</blockquote>
+
+<!-- End of entry for MAKE-READTABLE -->
+
+
+<!-- Entry for MERGE-READTABLES-INTO -->
+
+<p><br>[Function]<br><a class=none name='MERGE-READTABLES-INTO'><b>merge-readtables-into</b> <i>result-readtable <tt>&rest</tt> named-readtables</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>result-readtable</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>named-readtables</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>result</i>: <code>READTABLE</code></blockquote> Description:
+<blockquote>
+
+Copy the contents of each readtable in <i>named-readtables</i> into <br> <i>result-table</i>.
+<br><br>
+If a macro character appears in more than one of the readtables, i.e. if a conflict <br> is discovered during the merge, an error of type <code><a href="#Reader-Macro-Conflict"><code>READER-MACRO-CONFLICT</code></a></code> is signaled.
+
+
+</blockquote>
+
+<!-- End of entry for MERGE-READTABLES-INTO -->
+
+
+<!-- Entry for NAMED-READTABLE-DESIGNATOR -->
+
+<p><br>[Type]<br><a class=none name='NAMED-READTABLE-DESIGNATOR'><b>named-readtable-designator</b></a><br><br> Description:
+<blockquote>
+
+Either a symbol or a readtable itself.
+
+
+</blockquote>
+
+<!-- End of entry for NAMED-READTABLE-DESIGNATOR -->
+
+
+<!-- Entry for READER-MACRO-CONFLICT -->
+
+<p><br>[Condition type]<br><a class=none name='READER-MACRO-CONFLICT'><b>reader-macro-conflict</b></a><br><br> Description:
+<blockquote>
+
+Continuable.
+<br><br>
+This condition is signaled during the merge process if a) a reader macro (be it a <br> macro character or the sub character of a dispatch macro character) is both present <br> in the source as well as the target readtable, and b) if and only if the two <br> respective reader macro functions differ.
+
+
+</blockquote>
+
+<!-- End of entry for READER-MACRO-CONFLICT -->
+
+
+<!-- Entry for READTABLE-DOES-ALREADY-EXIST -->
+
+<p><br>[Condition type]<br><a class=none name='READTABLE-DOES-ALREADY-EXIST'><b>readtable-does-already-exist</b></a><br><br> Description:
+<blockquote>
+
+Continuable.
+
+
+</blockquote>
+
+<!-- End of entry for READTABLE-DOES-ALREADY-EXIST -->
+
+
+<!-- Entry for READTABLE-DOES-NOT-EXIST -->
+
+<p><br>[Condition type]<br><a class=none name='READTABLE-DOES-NOT-EXIST'><b>readtable-does-not-exist</b></a><br><br>
+<blockquote>
+
+
+
+</blockquote>
+
+<!-- End of entry for READTABLE-DOES-NOT-EXIST -->
+
+
+<!-- Entry for READTABLE-NAME -->
+
+<p><br>[Function]<br><a class=none name='READTABLE-NAME'><b>readtable-name</b> <i>named-readtable</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>named-readtable</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>result</i>: <code>SYMBOL</code></blockquote> Description:
+<blockquote>
+
+Returns the name of the readtable designated by <i>named-readtable</i>, or <code>NIL.</code>
+
+
+</blockquote>
+
+<!-- End of entry for READTABLE-NAME -->
+
+
+<!-- Entry for REGISTER-READTABLE -->
+
+<p><br>[Function]<br><a class=none name='REGISTER-READTABLE'><b>register-readtable</b> <i>name readtable</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>name</i>: <code>SYMBOL</code></blockquote><blockquote><i>readtable</i>: <code>READTABLE</code></blockquote><blockquote><i>result</i>: <code>READTABLE</code></blockquote> Description:
+<blockquote>
+
+Associate <i>readtable</i> with <i>name</i>. Returns the readtable.
+
+
+</blockquote>
+
+<!-- End of entry for REGISTER-READTABLE -->
+
+
+<!-- Entry for RENAME-READTABLE -->
+
+<p><br>[Function]<br><a class=none name='RENAME-READTABLE'><b>rename-readtable</b> <i>old-name new-name</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>old-name</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>new-name</i>: <code>SYMBOL</code></blockquote><blockquote><i>result</i>: <code>READTABLE</code></blockquote> Description:
+<blockquote>
+
+Replaces the associated name of the readtable designated by <i>old-name</i> with <br> <i>new-name</i>. If a readtable is already registered under <i>new-name</i>, an <br> error of type <code><a href="#Readtable-Does-Already-Exist"><code>READTABLE-DOES-ALREADY-EXIST</code></a></code> is signaled.
+
+
+</blockquote>
+
+<!-- End of entry for RENAME-READTABLE -->
+
+
+<!-- Entry for UNREGISTER-READTABLE -->
+
+<p><br>[Function]<br><a class=none name='UNREGISTER-READTABLE'><b>unregister-readtable</b> <i>named-readtable</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>named-readtable</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>result</i>: <code>(MEMBER T
+ NIL)</code></blockquote> Description:
+<blockquote>
+
+Remove the association of <i>named-readtable</i>. Returns <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/a_t.htm"><code>T</code></a></code> if successfull, <code>NIL</code> <br> otherwise.
+
+
+</blockquote>
+
+<!-- End of entry for UNREGISTER-READTABLE -->
+
+
+<hr>
+<p>
+This documentation was generated on 2009-9-29 from a Lisp image using some home-brewn,
+duct-taped, <br> evolutionary hacked extension of Edi Weitz'
+<a href="http://weitz.de/documentation-template/">DOCUMENTATION-TEMPLATE</a>.
+</p>
+
+</body>
+</html>
\ No newline at end of file
Added: dependencies/trunk/named-readtables/named-readtables.asd
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/named-readtables.asd Tue Jan 26 15:20:07 2010
@@ -0,0 +1,50 @@
+;;; -*- Mode:Lisp -*-
+
+(in-package :cl-user)
+
+(defclass asdf::named-readtables-source-file (asdf:cl-source-file) ())
+
+#+sbcl
+(defmethod asdf:perform :around ((o asdf:compile-op)
+ (c asdf::named-readtables-source-file))
+ (let ((sb-ext:*derive-function-types* t))
+ (call-next-method)))
+
+
+(asdf:defsystem :named-readtables
+ :description "Library that creates a namespace for named readtable akin to the namespace of packages."
+ :author "Tobias C. Rittweiler <trittweiler at common-lisp.net>"
+ :version "1.0 (unpublished so far)"
+ :licence "BSD"
+ :default-component-class asdf::named-readtables-source-file
+ :components
+ ((:file "package")
+ (:file "utils" :depends-on ("package"))
+ (:file "define-api" :depends-on ("package" "utils"))
+ (:file "cruft" :depends-on ("package" "utils"))
+ (:file "named-readtables" :depends-on ("package" "utils" "cruft" "define-api"))))
+
+(defmethod asdf:perform ((o asdf:test-op)
+ (c (eql (asdf:find-system :named-readtables))))
+ (asdf:operate 'asdf:load-op :named-readtables-test)
+ (asdf:operate 'asdf:test-op :named-readtables-test))
+
+
+(asdf:defsystem :named-readtables-test
+ :description "Test suite for the Named-Readtables library."
+ :author "Tobias C. Rittweiler <trittweiler at common-lisp.net>"
+ :depends-on (:named-readtables)
+ :components
+ ((:module tests
+ :default-component-class asdf::named-readtables-source-file
+ :serial t
+ :components
+ ((:file "package")
+ (:file "rt" :depends-on ("package"))
+ (:file "tests" :depends-on ("package" "rt"))))))
+
+(defmethod asdf:perform ((o asdf:test-op)
+ (c (eql (asdf:find-system
+ :named-readtables-test))))
+ (let ((*package* (find-package :named-readtables-test)))
+ (funcall (intern (string '#:do-tests) *package*))))
\ No newline at end of file
Added: dependencies/trunk/named-readtables/named-readtables.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/named-readtables.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,527 @@
+;;;; -*- Mode:Lisp -*-
+;;;;
+;;;; Copyright (c) 2007 - 2009 Tobias C. Rittweiler <tcr at freebits.de>
+;;;; Copyright (c) 2007, Robert P. Goldman <rpgoldman at sift.info> and SIFT, LLC
+;;;;
+;;;; All rights reserved.
+;;;;
+;;;; See LICENSE for details.
+;;;;
+
+(in-package :editor-hints.named-readtables)
+
+;;;
+;;; ``This is enough of a foothold to implement a more elaborate
+;;; facility for using readtables in a localized way.''
+;;;
+;;; (X3J13 Cleanup Issue IN-SYNTAX)
+;;;
+
+;;;;;; DEFREADTABLE &c.
+
+(defmacro defreadtable (name &body options)
+ "Define a new named readtable, whose name is given by the symbol `name'.
+Or, if a readtable is already registered under that name, redefine that
+one.
+
+The readtable can be populated using the following `options':
+
+ (:MERGE `readtable-designators'+)
+
+ Merge the readtables designated into the new readtable being defined
+ as per MERGE-READTABLES-INTO.
+
+ If no :MERGE clause is given, an empty readtable is used. See
+ MAKE-READTABLE.
+
+ (:FUZE `readtable-designators'+)
+
+ Like :MERGE except:
+
+ Error conditions of type READER-MACRO-CONFLICT that are signaled
+ during the merge operation will be silently _continued_. It follows
+ that reader macros in earlier entries will be overwritten by later
+ ones.
+
+ (:DISPATCH-MACRO-CHAR `macro-char' `sub-char' `function')
+
+ Define a new sub character `sub-char' for the dispatching macro
+ character `macro-char', per SET-DISPATCH-MACRO-CHARACTER. You
+ probably have to define `macro-char' as a dispatching macro character
+ by the following option first.
+
+ (:MACRO-CHAR `macro-char' `function' [`non-terminating-p'])
+
+ Define a new macro character in the readtable, per SET-MACRO-CHARACTER.
+ If `function' is the keyword :DISPATCH, `macro-char' is made a
+ dispatching macro character, per MAKE-DISPATCH-MACRO-CHARACTER.
+
+ (:SYNTAX-FROM `from-readtable-designator' `from-char' `to-char')
+
+ Set the character syntax of `to-char' in the readtable being defined
+ to the same syntax as `from-char' as per SET-SYNTAX-FROM-CHAR.
+
+ (:CASE `case-mode')
+
+ Defines the /case sensitivity mode/ of the resulting readtable.
+
+Any number of option clauses may appear. The options are grouped by their
+type, but in each group the order the options appeared textually is
+preserved. The following groups exist and are executed in the following
+order: :MERGE and :FUZE (one group), :CASE, :MACRO-CHAR
+and :DISPATCH-MACRO-CHAR (one group), finally :SYNTAX-FROM.
+
+Notes:
+
+ The readtable is defined at load-time. If you want to have it available
+ at compilation time -- say to use its reader-macros in the same file as
+ its definition -- you have to wrap the DEFREADTABLE form in an explicit
+ EVAL-WHEN.
+
+ On redefinition, the target readtable is made empty first before it's
+ refilled according to the clauses.
+
+ NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are
+ preregistered readtable names.
+"
+ (check-type name symbol)
+ (when (reserved-readtable-name-p name)
+ (error "~A is the designator for a predefined readtable. ~
+ Not acceptable as a user-specified readtable name." name))
+ (flet ((process-option (option var)
+ (destructure-case option
+ ((:merge &rest readtable-designators)
+ `(merge-readtables-into ,var
+ ,@(mapcar #'(lambda (x) `',x) readtable-designators))) ; quotify
+ ((:fuze &rest readtable-designators)
+ `(handler-bind ((reader-macro-conflict #'continue))
+ (merge-readtables-into ,var
+ ,@(mapcar #'(lambda (x) `',x) readtable-designators))))
+ ((:dispatch-macro-char disp-char sub-char function)
+ `(set-dispatch-macro-character ,disp-char ,sub-char ,function ,var))
+ ((:macro-char char function &optional non-terminating-p)
+ (if (eq function :dispatch)
+ `(make-dispatch-macro-character ,char ,non-terminating-p ,var)
+ `(set-macro-character ,char ,function ,non-terminating-p ,var)))
+ ((:syntax-from from-rt-designator from-char to-char)
+ `(set-syntax-from-char ,to-char ,from-char
+ ,var (find-readtable ,from-rt-designator)))
+ ((:case mode)
+ `(setf (readtable-case ,var) ,mode))))
+ (remove-clauses (clauses options)
+ (setq clauses (if (listp clauses) clauses (list clauses)))
+ (remove-if-not #'(lambda (x) (member x clauses))
+ options :key #'first)))
+ (let* ((merge-clauses (remove-clauses '(:merge :fuze) options))
+ (case-clauses (remove-clauses :case options))
+ (macro-clauses (remove-clauses '(:macro-char :dispatch-macro-char)
+ options))
+ (syntax-clauses (remove-clauses :syntax-from options))
+ (other-clauses (set-difference options
+ (append merge-clauses case-clauses
+ macro-clauses syntax-clauses))))
+ (cond
+ ((not (null other-clauses))
+ (error "Bogus DEFREADTABLE clauses: ~/PPRINT-LINEAR/" other-clauses))
+ (t
+ `(eval-when (:load-toplevel :execute)
+ ;; The (FIND-READTABLE ...) isqrt important for proper
+ ;; redefinition semantics, as redefining has to modify the
+ ;; already existing readtable object.
+ (let ((readtable (find-readtable ',name)))
+ (cond ((not readtable)
+ (setq readtable (make-readtable ',name)))
+ (t
+ (setq readtable (%clear-readtable readtable))
+ (simple-style-warn "Overwriting already existing readtable ~S."
+ readtable)))
+ ,@(loop for option in merge-clauses
+ collect (process-option option 'readtable))
+ ,@(loop for option in case-clauses
+ collect (process-option option 'readtable))
+ ,@(loop for option in macro-clauses
+ collect (process-option option 'readtable))
+ ,@(loop for option in syntax-clauses
+ collect (process-option option 'readtable))
+ readtable)))))))
+
+(defmacro in-readtable (name)
+ "Set *READTABLE* to the readtable referred to by the symbol `name'."
+ (check-type name symbol)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; NB. The :LOAD-TOPLEVEL is needed for cases like (DEFVAR *FOO*
+ ;; (GET-MACRO-CHARACTER #\"))
+ (setf *readtable* (ensure-readtable ',name))
+ (when (find-package :swank)
+ (%frob-swank-readtable-alist *package* *readtable*))
+ ))
+
+;;; KLUDGE: [interim solution]
+;;;
+;;; We need support for this in Slime itself, because we want IN-READTABLE
+;;; to work on a per-file basis, and not on a per-package basis.
+;;;
+(defun %frob-swank-readtable-alist (package readtable)
+ (let ((readtable-alist (find-symbol (string '#:*readtable-alist*)
+ (find-package :swank))))
+ (when (boundp readtable-alist)
+ (pushnew (cons (package-name package) readtable)
+ (symbol-value readtable-alist)
+ :test #'(lambda (entry1 entry2)
+ (destructuring-bind (pkg-name1 . rt1) entry1
+ (destructuring-bind (pkg-name2 . rt2) entry2
+ (and (string= pkg-name1 pkg-name2)
+ (eq rt1 rt2)))))))))
+
+(deftype readtable-designator ()
+ `(or null readtable))
+
+(deftype named-readtable-designator ()
+ "Either a symbol or a readtable itself."
+ `(or readtable-designator symbol))
+
+
+(declaim (special *standard-readtable* *empty-readtable*))
+
+(define-api make-readtable
+ (&optional (name nil name-supplied-p) &key merge)
+ (&optional named-readtable-designator &key (:merge list) => readtable)
+ "Creates and returns a new readtable under the specified `name'.
+
+`merge' takes a list of NAMED-READTABLE-DESIGNATORS and specifies the
+readtables the new readtable is created from. (See the :MERGE clause of
+DEFREADTABLE for details.)
+
+If `merge' is NIL, an empty readtable is used instead.
+
+If `name' is not given, an anonymous empty readtable is returned.
+
+Notes:
+
+ An empty readtable is a readtable where each character's syntax is the
+ same as in the /standard readtable/ except that each macro character has
+ been made a constituent. Basically: whitespace stays whitespace,
+ everything else is constituent."
+ (cond ((not name-supplied-p)
+ (copy-readtable *empty-readtable*))
+ ((reserved-readtable-name-p name)
+ (error "~A is the designator for a predefined readtable. ~
+ Not acceptable as a user-specified readtable name." name))
+ ((let ((rt (find-readtable name)))
+ (and rt (prog1 nil
+ (cerror "Overwrite existing entry."
+ 'readtable-does-already-exist :readtable-name name)
+ ;; Explicitly unregister to make sure that we do not hold on
+ ;; of any reference to RT.
+ (unregister-readtable rt)))))
+ (t (let ((result (apply #'merge-readtables-into
+ ;; The first readtable specified in the :merge list is
+ ;; taken as the basis for all subsequent (destructive!)
+ ;; modifications (and hence it's copied.)
+ (copy-readtable (if merge
+ (ensure-readtable (first merge))
+ *empty-readtable*))
+ (rest merge))))
+
+ (register-readtable name result)))))
+
+(define-api rename-readtable
+ (old-name new-name)
+ (named-readtable-designator symbol => readtable)
+ "Replaces the associated name of the readtable designated by `old-name'
+with `new-name'. If a readtable is already registered under `new-name', an
+error of type READTABLE-DOES-ALREADY-EXIST is signaled."
+ (when (find-readtable new-name)
+ (cerror "Overwrite existing entry."
+ 'readtable-does-already-exist :readtable-name new-name))
+ (let* ((readtable (ensure-readtable old-name))
+ (readtable-name (readtable-name readtable)))
+ ;; We use the internal functions directly to omit repeated
+ ;; type-checking.
+ (%unassociate-name-from-readtable readtable-name readtable)
+ (%unassociate-readtable-from-name readtable-name readtable)
+ (%associate-name-with-readtable new-name readtable)
+ (%associate-readtable-with-name new-name readtable)
+ readtable))
+
+(define-api merge-readtables-into
+ (result-readtable &rest named-readtables)
+ (named-readtable-designator &rest named-readtable-designator => readtable)
+ "Copy the contents of each readtable in `named-readtables' into
+`result-table'.
+
+If a macro character appears in more than one of the readtables, i.e. if a
+conflict is discovered during the merge, an error of type
+READER-MACRO-CONFLICT is signaled."
+ (flet ((merge-into (to from)
+ (do-readtable ((char reader-fn non-terminating-p disp? table) from)
+ (check-reader-macro-conflict from to char)
+ (cond ((not disp?)
+ (set-macro-character char reader-fn non-terminating-p to))
+ (t
+ (ensure-dispatch-macro-character char non-terminating-p to)
+ (loop for (subchar . subfn) in table do
+ (check-reader-macro-conflict from to char subchar)
+ (set-dispatch-macro-character char subchar subfn to)))))
+ to))
+ (let ((result-table (ensure-readtable result-readtable)))
+ (dolist (table (mapcar #'ensure-readtable named-readtables))
+ (merge-into result-table table))
+ result-table)))
+
+(defun ensure-dispatch-macro-character (char &optional non-terminating-p
+ (readtable *readtable*))
+ (if (dispatch-macro-char-p char readtable)
+ t
+ (make-dispatch-macro-character char non-terminating-p readtable)))
+
+(define-api copy-named-readtable
+ (named-readtable)
+ (named-readtable-designator => readtable)
+ "Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument."
+ (copy-readtable (ensure-readtable named-readtable)))
+
+(define-api list-all-named-readtables () (=> list)
+ "Returns a list of all registered readtables. The returned list is
+guaranteed to be fresh, but may contain duplicates."
+ (mapcar #'ensure-readtable (%list-all-readtable-names)))
+
+
+(define-condition readtable-error (error) ())
+
+(define-condition readtable-does-not-exist (readtable-error)
+ ((readtable-name :initarg :readtable-name
+ :initform (required-argument)
+ :accessor missing-readtable-name
+ :type named-readtable-designator))
+ (:report (lambda (condition stream)
+ (format stream "A readtable named ~S does not exist."
+ (missing-readtable-name condition)))))
+
+(define-condition readtable-does-already-exist (readtable-error)
+ ((readtable-name :initarg :readtable-name
+ :initform (required-argument)
+ :accessor existing-readtable-name
+ :type named-readtable-designator))
+ (:report (lambda (condition stream)
+ (format stream "A readtable named ~S already exists."
+ (existing-readtable-name condition))))
+ (:documentation "Continuable."))
+
+(define-condition reader-macro-conflict (readtable-error)
+ ((macro-char
+ :initarg :macro-char
+ :initform (required-argument)
+ :accessor conflicting-macro-char
+ :type character)
+ (sub-char
+ :initarg :sub-char
+ :initform nil
+ :accessor conflicting-dispatch-sub-char
+ :type (or null character))
+ (from-readtable
+ :initarg :from-readtable
+ :initform (required-argument)
+ :accessor from-readtable
+ :type readtable)
+ (to-readtable
+ :initarg :to-readtable
+ :initform (required-argument)
+ :accessor to-readtable
+ :type readtable))
+ (:report
+ (lambda (condition stream)
+ (format stream "~@<Reader macro conflict while trying to merge the ~
+ ~:[macro character~;dispatch macro characters~] ~
+ ~@C~@[ ~@C~] from ~A into ~A.~@:>"
+ (conflicting-dispatch-sub-char condition)
+ (conflicting-macro-char condition)
+ (conflicting-dispatch-sub-char condition)
+ (from-readtable condition)
+ (to-readtable condition))))
+ (:documentation "Continuable.
+
+This condition is signaled during the merge process if a) a reader macro
+\(be it a macro character or the sub character of a dispatch macro
+character\) is both present in the source as well as the target readtable,
+and b) if and only if the two respective reader macro functions differ."))
+
+(defun check-reader-macro-conflict (from to char &optional subchar)
+ (flet ((conflictp (from-fn to-fn)
+ (assert from-fn) ; if this fails, there's a bug in readtable iterators.
+ (and to-fn (not (function= to-fn from-fn)))))
+ (when (if subchar
+ (conflictp (%get-dispatch-macro-character char subchar from)
+ (%get-dispatch-macro-character char subchar to))
+ (conflictp (%get-macro-character char from)
+ (%get-macro-character char to)))
+ (cerror (format nil "Overwrite ~@C in ~A." char to)
+ 'reader-macro-conflict
+ :from-readtable from
+ :to-readtable to
+ :macro-char char
+ :sub-char subchar))))
+
+
+;;; Although there is no way to get at the standard readtable in
+;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make
+;;; up the perception of its existence by interning a copy of it.
+;;;
+;;; We do this for reverse lookup (cf. READTABLE-NAME), i.e. for
+;;;
+;;; (equal (readtable-name (find-readtable :standard)) "STANDARD")
+;;;
+;;; holding true.
+;;;
+;;; We, however, inherit the restriction that the :STANDARD
+;;; readtable _must not be modified_ (cf. CLHS 2.1.1.2), although it'd
+;;; technically be feasible (as *STANDARD-READTABLE* will contain a
+;;; mutable copy of the implementation-internal standard readtable.)
+;;; We cannot enforce this restriction without shadowing
+;;; CL:SET-MACRO-CHARACTER and CL:SET-DISPATCH-MACRO-FUNCTION which
+;;; is out of scope of this library, though. So we just threaten
+;;; with nasal demons.
+;;;
+(defvar *standard-readtable*
+ (%standard-readtable))
+
+(defvar *empty-readtable*
+ (%clear-readtable (copy-readtable nil)))
+
+(defvar *case-preserving-standard-readtable*
+ (let ((readtable (copy-readtable nil)))
+ (setf (readtable-case readtable) :preserve)
+ readtable))
+
+(defparameter *reserved-readtable-names*
+ '(nil :standard :common-lisp :modern :current))
+
+(defun reserved-readtable-name-p (name)
+ (and (member name *reserved-readtable-names*) t))
+
+;;; In principle, we could DEFREADTABLE some of these. But we do
+;;; reserved readtable lookup seperately, since we can't register a
+;;; readtable for :CURRENT anyway.
+
+(defun find-reserved-readtable (reserved-name)
+ (cond ((eq reserved-name nil) *standard-readtable*)
+ ((eq reserved-name :standard) *standard-readtable*)
+ ((eq reserved-name :common-lisp) *standard-readtable*)
+ ((eq reserved-name :modern) *case-preserving-standard-readtable*)
+ ((eq reserved-name :current) *readtable*)
+ (t (error "Bug: no such reserved readtable: ~S" reserved-name))))
+
+(define-api find-readtable
+ (name)
+ (named-readtable-designator => (or readtable null))
+ "Looks for the readtable specified by `name' and returns it if it is
+found. Returns NIL otherwise."
+ (cond ((readtablep name) name)
+ ((reserved-readtable-name-p name)
+ (find-reserved-readtable name))
+ ((%find-readtable name))))
+
+;;; FIXME: This doesn't take a NAMED-READTABLE-DESIGNATOR, but only a
+;;; STRING-DESIGNATOR. (When fixing, heed interplay with compiler
+;;; macros below.)
+(defsetf find-readtable register-readtable)
+
+(define-api ensure-readtable
+ (name &optional (default nil default-p))
+ (named-readtable-designator &optional (or named-readtable-designator null)
+ => readtable)
+ "Looks up the readtable specified by `name' and returns it if it's found.
+If it is not found, it registers the readtable designated by `default'
+under the name represented by `name'; or if no default argument is given,
+it signals an error of type READTABLE-DOES-NOT-EXIST instead."
+ (cond ((find-readtable name))
+ ((not default-p)
+ (error 'readtable-does-not-exist :readtable-name name))
+ (t (setf (find-readtable name) (ensure-readtable default)))))
+
+
+(define-api register-readtable
+ (name readtable)
+ (symbol readtable => readtable)
+ "Associate `readtable' with `name'. Returns the readtable."
+ (assert (typep name '(not (satisfies reserved-readtable-name-p))))
+ (%associate-readtable-with-name name readtable)
+ (%associate-name-with-readtable name readtable)
+ readtable)
+
+(define-api unregister-readtable
+ (named-readtable)
+ (named-readtable-designator => boolean)
+ "Remove the association of `named-readtable'. Returns T if successfull,
+NIL otherwise."
+ (let* ((readtable (find-readtable named-readtable))
+ (readtable-name (and readtable (readtable-name readtable))))
+ (if (not readtable-name)
+ nil
+ (prog1 t
+ (check-type readtable-name (not (satisfies reserved-readtable-name-p)))
+ (%unassociate-readtable-from-name readtable-name readtable)
+ (%unassociate-name-from-readtable readtable-name readtable)))))
+
+(define-api readtable-name
+ (named-readtable)
+ (named-readtable-designator => symbol)
+ "Returns the name of the readtable designated by `named-readtable', or
+NIL."
+ (let ((readtable (ensure-readtable named-readtable)))
+ (cond ((%readtable-name readtable))
+ ((eq readtable *readtable*) :current)
+ ((eq readtable *standard-readtable*) :common-lisp)
+ ((eq readtable *case-preserving-standard-readtable*) :modern)
+ (t nil))))
+
+
+;;;;; Compiler macros
+
+;;; Since the :STANDARD readtable is interned, and we can't enforce
+;;; its immutability, we signal a style-warning for suspicious uses
+;;; that may result in strange behaviour:
+
+;;; Modifying the standard readtable would, obviously, lead to a
+;;; propagation of this change to all places which use the :STANDARD
+;;; readtable (and thus rendering this readtable to be non-standard,
+;;; in fact.)
+
+
+(defun constant-standard-readtable-expression-p (thing)
+ (cond ((symbolp thing) (or (eq thing 'nil) (eq thing :standard)))
+ ((consp thing) (some (lambda (x) (equal thing x))
+ '((find-readtable nil)
+ (find-readtable :standard)
+ (ensure-readtable nil)
+ (ensure-readtable :standard))))
+ (t nil)))
+
+(defun signal-suspicious-registration-warning (name-expr readtable-expr)
+ (simple-style-warn
+ "Caution: ~<You're trying to register the :STANDARD readtable ~
+ under a new name ~S. As modification of the :STANDARD readtable ~
+ is not permitted, subsequent modification of ~S won't be ~
+ permitted either. You probably want to wrap COPY-READTABLE ~
+ around~@:>~% ~S"
+ (list name-expr name-expr) readtable-expr))
+
+(let ()
+ ;; Defer to runtime because compiler-macros are made available already
+ ;; at compilation time. So without this two subsequent invocations of
+ ;; COMPILE-FILE on this file would result in an undefined function
+ ;; error because the two above functions are not yet available.
+ ;; (This does not use EVAL-WHEN because of Fig 3.7, CLHS 3.2.3.1;
+ ;; cf. last example in CLHS "EVAL-WHEN" entry.)
+
+ (define-compiler-macro register-readtable (&whole form name readtable)
+ (when (constant-standard-readtable-expression-p readtable)
+ (signal-suspicious-registration-warning name readtable))
+ form)
+
+ (define-compiler-macro ensure-readtable (&whole form name &optional (default nil default-p))
+ (when (and default-p (constant-standard-readtable-expression-p default))
+ (signal-suspicious-registration-warning name default))
+ form))
+
+
Added: dependencies/trunk/named-readtables/package.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/package.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,193 @@
+
+(in-package :common-lisp-user)
+
+(defpackage :editor-hints.named-readtables
+ (:use :common-lisp)
+ (:nicknames :named-readtables)
+ (:export
+ #:defreadtable
+ #:in-readtable
+ #:make-readtable
+ #:merge-readtables-into
+ #:find-readtable
+ #:ensure-readtable
+ #:rename-readtable
+ #:readtable-name
+ #:register-readtable
+ #:unregister-readtable
+ #:copy-named-readtable
+ #:list-all-named-readtables
+ ;; Types
+ #:named-readtable-designator
+ ;; Conditions
+ #:reader-macro-conflict
+ #:readtable-does-already-exist
+ #:readtable-does-not-exist
+ )
+ (:documentation
+ "
+* What are Named-Readtables?
+
+ Named-Readtables is a library that provides a namespace for
+ readtables akin to the already-existing namespace of packages. In
+ particular:
+
+ * you can associate readtables with names, and retrieve
+ readtables by names;
+
+ * you can associate source files with readtable names, and be
+ sure that the right readtable is active when compiling/loading
+ the file;
+
+ * similiarly, your development environment now has a chance to
+ automatically determine what readtable should be active while
+ processing source forms on interactive commands. (E.g. think of
+ `C-c C-c' in Slime [yet to be done])
+
+ It follows that Named-Readtables is a facility for using readtables in
+ a localized way.
+
+ Additionally, it also attempts to become a facility for using
+ readtables in a _modular_ way. In particular:
+
+ * it provides a macro to specify the content of a readtable at a
+ glance;
+
+ * it makes it possible to use multiple inheritance between readtables.
+
+* Notes on the API
+
+ The API heavily imitates the API of packages. This has the nice
+ property that any experienced Common Lisper will take it up without
+ effort.
+
+ DEFREADTABLE - DEFPACKAGE
+
+ IN-READTABLE - IN-PACKAGE
+
+ MERGE-READTABLES-INTO - USE-PACKAGE
+
+ MAKE-READTABLE - MAKE-PACKAGE
+
+ UNREGISTER-READTABLE - DELETE-PACKAGE
+
+ RENAME-READTABLE - RENAME-PACKAGE
+
+ FIND-READTABLE - FIND-PACKAGE
+
+ READTABLE-NAME - PACKAGE-NAME
+
+ LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES
+
+* Important API idiosyncrasies
+
+ There are three major differences between the API of Named-Readtables,
+ and the API of packages.
+
+ 1. Readtable names are symbols not strings.
+
+ Time has shown that the fact that packages are named by
+ strings causes severe headache because of the potential of
+ package names colliding with each other.
+
+ Hence, readtables are named by symbols lest to make the
+ situation worse than it already is. Consequently, readtables
+ named CL-ORACLE:SQL-SYNTAX and CL-MYSQL:SQL-SYNTAX can
+ happily coexist next to each other. Or, taken to an extreme,
+ SCHEME:SYNTAX and ELISP:SYNTAX.
+
+ If, for example to duly signify the importance of your cool
+ readtable hack, you really think it deserves a global name,
+ you can always resort to keywords.
+
+ 2. The inheritance is resolved statically, not dynamically.
+
+ A package that uses another package will have access to all
+ the other package's exported symbols, even to those that will
+ be added after its definition. I.e. the inheritance is
+ resolved at run-time, that is dynamically.
+
+ Unfortunately, we cannot do the same for readtables in a
+ portable manner.
+
+ Therefore, we do not talk about \"using\" another readtable
+ but about \"merging\" the other readtable's definition into
+ the readtable we are going to define. I.e. the inheritance is
+ resolved once at definition time, that is statically.
+
+ (Such merging can more or less be implemented portably albeit
+ at a certain cost. Most of the time, this cost manifests
+ itself at the time a readtable is defined, i.e. once at
+ compile-time, so it may not bother you. Nonetheless, we
+ provide extra support for Sbcl, ClozureCL, and AllegroCL at
+ the moment. Patches for your implementation of choice are
+ welcome, of course.)
+
+ 3. DEFREADTABLE does not have compile-time effects.
+
+ If you define a package via DEFPACKAGE, you can make that
+ package the currently active package for the subsequent
+ compilation of the same file via IN-PACKAGE. The same is,
+ however, not true for DEFREADTABLE and IN-READTABLE for the
+ following reason:
+
+ It's unlikely that the need for special reader-macros arises
+ for a problem which can be solved in just one file. Most
+ often, you're going to define the reader macro functions, and
+ set up the corresponding readtable in an extra file.
+
+ If DEFREADTABLE had compile-time effects, you'd have to wrap
+ each definition of a reader-macro function in an EVAL-WHEN to
+ make its definition available at compile-time. Because that's
+ simply not the common case, DEFREADTABLE does not have a
+ compile-time effect.
+
+ If you want to use a readtable within the same file as its
+ definition, wrap the DEFREADTABLE and the reader-macro
+ function definitions in an explicit EVAL-WHEN.
+
+* Preregistered Readtables
+
+ - NIL, :STANDARD, and :COMMON-LISP designate the /standard readtable/.
+
+ - :MODERN designates a _case-preserving_ /standard-readtable/.
+
+ - :CURRENT designates the /current readtable/.
+
+* Examples
+
+ > (defreadtable elisp:syntax
+ > (:merge :standard)
+ > (:macro-char #\\? #'elisp::read-character-literal t)
+ > (:macro-char #\\[ #'elisp::read-vector-literal t)
+ > ...
+ > (:case :preserve))
+ >
+ > (defreadtable scheme:syntax
+ > (:merge :standard)
+ > (:macro-char #\\[ #'(lambda (stream char)
+ > (read-delimited-list #\\] stream)))
+ > (:macro-char #\\# :dispatch)
+ > (:dispatch-macro-char #\\# #\\t #'scheme::read-#t)
+ > (:dispatch-macro-char #\\# #\\f #'scheme::read-#f)
+ > ...
+ > (:case :preserve))
+ >
+ > (in-readtable elisp:syntax)
+ >
+ > ...
+ >
+ > (in-readtable scheme:syntax)
+ >
+ > ...
+
+* Acknowledgements
+
+ Thanks to Robert Goldman for making me want to write this library.
+
+ Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart
+ Botta, David Crawford, and Pascal Costanza for being early adopters,
+ providing comments and bugfixes.
+"))
+
+(pushnew :named-readtables *features*)
\ No newline at end of file
Added: dependencies/trunk/named-readtables/tests/package.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/tests/package.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,12 @@
+;;; -*- Mode:Lisp -*-
+
+(in-package :cl-user)
+
+(defpackage :named-readtables-test
+ (:use :cl :named-readtables)
+ (:import-from :named-readtables
+ #:dispatch-macro-char-p
+ #:do-readtable
+ #:ensure-function
+ #:ensure-dispatch-macro-character
+ #:function=))
\ No newline at end of file
Added: dependencies/trunk/named-readtables/tests/rt.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/tests/rt.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,256 @@
+#|----------------------------------------------------------------------------|
+ | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
+ | |
+ | Permission to use, copy, modify, and distribute this software and its |
+ | documentation for any purpose and without fee is hereby granted, provided |
+ | that this copyright and permission notice appear in all copies and |
+ | supporting documentation, and that the name of M.I.T. not be used in |
+ | advertising or publicity pertaining to distribution of the software |
+ | without specific, written prior permission. M.I.T. makes no |
+ | representations about the suitability of this software for any purpose. |
+ | It is provided "as is" without express or implied warranty. |
+ | |
+ | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
+ | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
+ | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
+ | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
+ | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
+ | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
+ | SOFTWARE. |
+ |----------------------------------------------------------------------------|#
+
+;; (defpackage :rt
+;; (:use #:cl)
+;; (:export #:*do-tests-when-defined* #:*test* #:continue-testing
+;; #:deftest #:do-test #:do-tests #:get-test #:pending-tests
+;; #:rem-all-tests #:rem-test)
+;; (:documentation "The MIT regression tester"))
+
+;; (in-package :rt)
+
+(in-package :named-readtables-test)
+
+(defvar *test* nil "Current test name")
+(defvar *do-tests-when-defined* nil)
+(defvar *entries* '(nil) "Test database")
+(defvar *in-test* nil "Used by TEST")
+(defvar *debug* nil "For debugging")
+(defvar *catch-errors* t
+ "When true, causes errors in a test to be caught.")
+(defvar *print-circle-on-failure* nil
+ "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
+(defvar *compile-tests* nil
+ "When true, compile the tests before running them.")
+(defvar *optimization-settings* '((safety 3)))
+(defvar *expected-failures* nil
+ "A list of test names that are expected to fail.")
+
+(defstruct (entry (:conc-name nil)
+ (:type list))
+ pend name form)
+
+(defmacro vals (entry) `(cdddr ,entry))
+
+(defmacro defn (entry) `(cdr ,entry))
+
+(defun pending-tests ()
+ (do ((l (cdr *entries*) (cdr l))
+ (r nil))
+ ((null l) (nreverse r))
+ (when (pend (car l))
+ (push (name (car l)) r))))
+
+(defun rem-all-tests ()
+ (setq *entries* (list nil))
+ nil)
+
+(defun rem-test (&optional (name *test*))
+ (do ((l *entries* (cdr l)))
+ ((null (cdr l)) nil)
+ (when (equal (name (cadr l)) name)
+ (setf (cdr l) (cddr l))
+ (return name))))
+
+(defun get-test (&optional (name *test*))
+ (defn (get-entry name)))
+
+(defun get-entry (name)
+ (let ((entry (find name (cdr *entries*)
+ :key #'name
+ :test #'equal)))
+ (when (null entry)
+ (report-error t
+ "~%No test with name ~:@(~S~)."
+ name))
+ entry))
+
+(defmacro deftest (name form &rest values)
+ `(add-entry '(t ,name ,form .,values)))
+
+(defun add-entry (entry)
+ (setq entry (copy-list entry))
+ (do ((l *entries* (cdr l))) (nil)
+ (when (null (cdr l))
+ (setf (cdr l) (list entry))
+ (return nil))
+ (when (equal (name (cadr l))
+ (name entry))
+ (setf (cadr l) entry)
+ (report-error nil
+ "Redefining test ~:@(~S~)"
+ (name entry))
+ (return nil)))
+ (when *do-tests-when-defined*
+ (do-entry entry))
+ (setq *test* (name entry)))
+
+(defun report-error (error? &rest args)
+ (cond (*debug*
+ (apply #'format t args)
+ (if error? (throw '*debug* nil)))
+ (error? (apply #'error args))
+ (t (apply #'warn args))))
+
+(defun do-test (&optional (name *test*))
+ (do-entry (get-entry name)))
+
+(defun equalp-with-case (x y)
+ "Like EQUALP, but doesn't do case conversion of characters."
+ (cond
+ ((eq x y) t)
+ ((consp x)
+ (and (consp y)
+ (equalp-with-case (car x) (car y))
+ (equalp-with-case (cdr x) (cdr y))))
+ ((and (typep x 'array)
+ (= (array-rank x) 0))
+ (equalp-with-case (aref x) (aref y)))
+ ((typep x 'vector)
+ (and (typep y 'vector)
+ (let ((x-len (length x))
+ (y-len (length y)))
+ (and (eql x-len y-len)
+ (loop
+ for e1 across x
+ for e2 across y
+ always (equalp-with-case e1 e2))))))
+ ((and (typep x 'array)
+ (typep y 'array)
+ (not (equal (array-dimensions x)
+ (array-dimensions y))))
+ nil)
+ ((typep x 'array)
+ (and (typep y 'array)
+ (let ((size (array-total-size x)))
+ (loop for i from 0 below size
+ always (equalp-with-case (row-major-aref x i)
+ (row-major-aref y i))))))
+ (t (eql x y))))
+
+(defun do-entry (entry &optional
+ (s *standard-output*))
+ (catch '*in-test*
+ (setq *test* (name entry))
+ (setf (pend entry) t)
+ (let* ((*in-test* t)
+ ;; (*break-on-warnings* t)
+ (aborted nil)
+ r)
+ ;; (declare (special *break-on-warnings*))
+
+ (block aborted
+ (setf r
+ (flet ((%do
+ ()
+ (if *compile-tests*
+ (multiple-value-list
+ (funcall (compile
+ nil
+ `(lambda ()
+ (declare
+ (optimize ,@*optimization-settings*))
+ ,(form entry)))))
+ (multiple-value-list
+ (eval (form entry))))))
+ (if *catch-errors*
+ (handler-bind
+ ((style-warning #'muffle-warning)
+ (error #'(lambda (c)
+ (setf aborted t)
+ (setf r (list c))
+ (return-from aborted nil))))
+ (%do))
+ (%do)))))
+
+ (setf (pend entry)
+ (or aborted
+ (not (equalp-with-case r (vals entry)))))
+
+ (when (pend entry)
+ (let ((*print-circle* *print-circle-on-failure*))
+ (format s "~&Test ~:@(~S~) failed~
+ ~%Form: ~S~
+ ~%Expected value~P: ~
+ ~{~S~^~%~17t~}~%"
+ *test* (form entry)
+ (length (vals entry))
+ (vals entry))
+ (format s "Actual value~P: ~
+ ~{~S~^~%~15t~}.~%"
+ (length r) r)))))
+ (when (not (pend entry)) *test*))
+
+(defun continue-testing ()
+ (if *in-test*
+ (throw '*in-test* nil)
+ (do-entries *standard-output*)))
+
+(defun do-tests (&optional
+ (out *standard-output*))
+ (dolist (entry (cdr *entries*))
+ (setf (pend entry) t))
+ (if (streamp out)
+ (do-entries out)
+ (with-open-file
+ (stream out :direction :output)
+ (do-entries stream))))
+
+(defun do-entries (s)
+ (format s "~&Doing ~A pending test~:P ~
+ of ~A tests total.~%"
+ (count t (cdr *entries*)
+ :key #'pend)
+ (length (cdr *entries*)))
+ (dolist (entry (cdr *entries*))
+ (when (pend entry)
+ (format s "~@[~<~%~:; ~:@(~S~)~>~]"
+ (do-entry entry s))))
+ (let ((pending (pending-tests))
+ (expected-table (make-hash-table :test #'equal)))
+ (dolist (ex *expected-failures*)
+ (setf (gethash ex expected-table) t))
+ (let ((new-failures
+ (loop for pend in pending
+ unless (gethash pend expected-table)
+ collect pend)))
+ (if (null pending)
+ (format s "~&No tests failed.")
+ (progn
+ (format s "~&~A out of ~A ~
+ total tests failed: ~
+ ~:@(~{~<~% ~1:;~S~>~
+ ~^, ~}~)."
+ (length pending)
+ (length (cdr *entries*))
+ pending)
+ (if (null new-failures)
+ (format s "~&No unexpected failures.")
+ (when *expected-failures*
+ (format s "~&~A unexpected failures: ~
+ ~:@(~{~<~% ~1:;~S~>~
+ ~^, ~}~)."
+ (length new-failures)
+ new-failures)))
+ ))
+ (finish-output s)
+ (null pending))))
Added: dependencies/trunk/named-readtables/tests/tests.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/tests/tests.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,322 @@
+;;; -*- Mode:Lisp -*-
+
+(in-package :named-readtables-test)
+
+(defun map-alist (car-fn cdr-fn alist)
+ (mapcar #'(lambda (entry)
+ (cons (funcall car-fn (car entry))
+ (funcall cdr-fn (cdr entry))))
+ alist))
+
+(defun length=1 (list)
+ (and list (null (cdr list))))
+
+(defmacro signals-condition-p (name &body body)
+ `(handler-case (prog1 nil , at body)
+ (,(second name) () t)))
+
+(defmacro continue-condition (name &body body)
+ `(handler-bind ((,(second name) #'continue))
+ , at body))
+
+(defun read-with-readtable (name string)
+ (let ((*package* '#.*package*)
+ (*readtable* (find-readtable name)))
+ (values (read-from-string string))))
+
+(defun random-named-readtable ()
+ (let ((readtables (list-all-named-readtables)))
+ (nth (random (length readtables)) readtables)))
+
+
+(defun readtable-content (named-readtable-designator)
+ (let ((readtable (ensure-readtable named-readtable-designator))
+ (result '()))
+ ;; Make sure to canonicalize the order and function designators so
+ ;; we can compare easily.
+ (do-readtable ((char reader-fn ntp disp? table) readtable)
+ (setq table (sort (copy-list table) #'char< :key #'car))
+ (push (list* char
+ (ensure-function reader-fn)
+ ntp
+ (and disp? (list (map-alist #'identity
+ #'ensure-function
+ table))))
+ result))
+ (sort result #'char< :key #'car)))
+
+(defun readtable= (rt1 rt2)
+ (tree-equal (readtable-content rt1) (readtable-content rt2)
+ :test #'(lambda (x y)
+ (if (and (functionp x) (functionp y))
+ (function= x y)
+ (eql x y)))))
+
+
+(defun read-A (stream c)
+ (declare (ignore stream c))
+ :a)
+
+(defun read-A-as-X (stream c)
+ (declare (ignore stream c))
+ :x)
+
+(defun read-B (stream c)
+ (declare (ignore stream c))
+ :b)
+
+(defun read-sharp-paren (stream c n)
+ (declare (ignore stream c n))
+ 'sharp-paren)
+
+(defun read-C (stream c)
+ (declare (ignore stream c))
+ :c)
+
+(defreadtable A
+ (:macro-char #\A #'read-A))
+
+(defreadtable A-as-X
+ (:macro-char #\A #'read-A-as-X))
+
+(defreadtable B
+ (:macro-char #\B #'read-B))
+
+(defreadtable C
+ (:macro-char #\C #'read-C))
+
+(defreadtable A+B+C
+ (:merge A B C))
+
+(defreadtable standard+A+B+C
+ (:merge :standard A+B+C))
+
+(defreadtable sharp-paren
+ (:macro-char #\# :dispatch)
+ (:dispatch-macro-char #\# #\( #'read-sharp-paren))
+
+
+(deftest cruft.1
+ (function= (get-macro-character #\" (copy-readtable nil))
+ (get-macro-character #\" (copy-readtable nil)))
+ t)
+
+(deftest cruft.2
+ (dispatch-macro-char-p #\# (find-readtable :standard))
+ t)
+
+(deftest cruft.3
+ (dispatch-macro-char-p #\# (make-readtable))
+ nil)
+
+(deftest cruft.4
+ (let ((rt (copy-named-readtable :standard)))
+ (ensure-dispatch-macro-character #\# t rt)
+ (dispatch-macro-char-p #\# rt))
+ t)
+
+(deftest cruft.5
+ (let ((rt (make-readtable)))
+ (values
+ (dispatch-macro-char-p #\$ rt)
+ (ensure-dispatch-macro-character #\$ t rt)
+ (dispatch-macro-char-p #\$ rt)))
+ nil t t)
+
+(deftest cruft.6
+ (let ((rt (make-readtable))
+ (fn (constantly nil)))
+ (ensure-dispatch-macro-character #\$ t rt)
+ (set-dispatch-macro-character #\$ #\# fn rt)
+ (values
+ (eq fn (get-dispatch-macro-character #\$ #\# rt))
+ (length=1 (readtable-content rt))))
+ t t)
+
+(deftest cruft.7
+ (let ((rt (make-readtable))
+ (fn (constantly nil)))
+ (set-macro-character #\$ fn t rt)
+ (values
+ (eq fn (get-macro-character #\$ rt))
+ (length=1 (readtable-content rt))))
+ t t)
+
+
+(deftest standard.1
+ (read-with-readtable :standard "ABC")
+ ABC)
+
+(deftest standard.2
+ (read-with-readtable :standard "(A B C)")
+ (A B C))
+
+(deftest standard.3
+ (let ((x (find-readtable nil))
+ (y (find-readtable :standard))
+ (z (find-readtable :common-lisp)))
+ (and (eq x y) (eq y z)))
+ t)
+
+
+(deftest modern.1
+ (read-with-readtable :modern "FooF")
+ |FooF|)
+
+
+(deftest empty.1
+ (null (readtable-content (make-readtable)))
+ t)
+
+(deftest empty.2
+ (readtable= (merge-readtables-into (make-readtable) :standard)
+ (find-readtable :standard))
+ t)
+
+(deftest empty.3
+ (let ((rt (copy-named-readtable :standard)))
+ (readtable= (merge-readtables-into (make-readtable) rt)
+ (merge-readtables-into rt (make-readtable))))
+ t)
+
+
+(deftest basics.1
+ (read-with-readtable 'A "A")
+ :a)
+
+(deftest basics.2
+ (read-with-readtable 'A-as-X "A")
+ :x)
+
+(deftest basics.3
+ (read-with-readtable 'A "B")
+ B)
+
+(deftest basics.4
+ (read-with-readtable 'A "(A B C)")
+ |(|)
+
+
+(deftest unregister.1
+ (let ((rt (find-readtable 'A)))
+ (register-readtable 'does-not-exist rt)
+ (values
+ (and (find-readtable 'does-not-exist) t)
+ (unregister-readtable 'does-not-exist)
+ (and (find-readtable 'does-not-exist) t)))
+ t t nil)
+
+
+(deftest name.1
+ (let ((rt (random-named-readtable)))
+ (eq rt (find-readtable (readtable-name rt))))
+ t)
+
+(deftest ensure.1
+ (unwind-protect
+ (let* ((x (ensure-readtable 'does-not-exist (find-readtable 'A)))
+ (y (find-readtable 'A))
+ (z (find-readtable 'does-not-exist)))
+ (and (eq x y) (eq y z)))
+ (unregister-readtable 'does-not-exist))
+ t)
+
+
+(deftest merge.1
+ (values
+ (read-with-readtable 'A+B+C "A")
+ (read-with-readtable 'A+B+C "B")
+ (read-with-readtable 'A+B+C "C"))
+ :a :b :c)
+
+(deftest merge.2
+ (read-with-readtable 'standard+A+B+C "(A B C)")
+ (:a :b :c))
+
+(deftest merge.3
+ (read-with-readtable 'standard+A+B+C "#(A B C)")
+ #(:a :b :c))
+
+(deftest merge.4
+ (let ((A+B+C+standard (merge-readtables-into (copy-named-readtable 'A+B+C)
+ :standard)))
+ (readtable= 'standard+A+B+C A+B+C+standard))
+ t)
+
+
+(deftest rename.1
+ (unwind-protect
+ (progn (make-readtable 'A* :merge '(A))
+ (rename-readtable 'A* 'A**)
+ (values (and (find-readtable 'A*) t)
+ (and (find-readtable 'A**) t)))
+ (unregister-readtable 'A*)
+ (unregister-readtable 'A**))
+ nil
+ t)
+
+
+(deftest reader-macro-conflict.1
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) 'A 'A-as-X))
+ t)
+
+(deftest reader-macro-conflict.2
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) :standard :standard))
+ nil)
+
+(deftest reader-macro-conflict.3
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) 'A+B+C 'A))
+ nil)
+
+(deftest reader-macro-conflict.4
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) :standard 'sharp-paren))
+ t)
+
+
+(deftest readtable-does-not-exist.1
+ (signals-condition-p 'readtable-does-not-exist
+ (ensure-readtable 'does-not-exist))
+ t)
+
+
+(deftest readtable-does-already-exist.1
+ (signals-condition-p 'readtable-does-already-exist
+ (make-readtable 'A))
+ t)
+
+(deftest readtable-does-already-exist.2
+ (signals-condition-p 'readtable-does-already-exist
+ (make-readtable 'A))
+ t)
+
+(deftest readtable-does-already-exist.3
+ (let ((rt (make-readtable 'does-not-exist :merge '(:standard A B))))
+ (declare (ignore rt))
+ (unwind-protect
+ (read-with-readtable (continue-condition 'readtable-does-already-exist
+ (make-readtable 'does-not-exist
+ :merge '(:standard A C)))
+
+ "(A B C)")
+ (unregister-readtable 'does-not-exist)))
+ (:a B :c))
+
+
+(deftest defreadtable.1
+ (unwind-protect
+ (signals-condition-p 'reader-macro-conflict
+ (eval `(defreadtable does-not-exist (:merge A A-as-X))))
+ (unregister-readtable 'does-not-exist))
+ t)
+
+(deftest defreadtable.2
+ (unwind-protect
+ (signals-condition-p 't
+ (eval `(defreadtable does-not-exist (:fuze A A-as-X))))
+ (unregister-readtable 'does-not-exist))
+ nil)
+
Added: dependencies/trunk/named-readtables/utils.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/utils.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,245 @@
+;;;;
+;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler <tcr at freebits.de>
+;;;;
+;;;; All rights reserved.
+;;;;
+;;;; See LICENSE for details.
+;;;;
+
+(in-package :editor-hints.named-readtables)
+
+(defmacro without-package-lock ((&rest package-names) &body body)
+ (declare (ignorable package-names))
+ #+clisp
+ (return-from without-package-lock
+ `(ext:without-package-lock (, at package-names) , at body))
+ #+lispworks
+ (return-from without-package-lock
+ `(let ((hcl:*packages-for-warn-on-redefinition*
+ (set-difference hcl:*packages-for-warn-on-redefinition*
+ '(, at package-names)
+ :key (lambda (package-designator)
+ (if (packagep package-designator)
+ (package-name package-designator)
+ package-designator))
+ :test #'string=)))
+ , at body))
+ `(progn , at body))
+
+;;; Taken from SWANK (which is Public Domain.)
+
+(defmacro destructure-case (value &rest patterns)
+ "Dispatch VALUE to one of PATTERNS.
+A cross between `case' and `destructuring-bind'.
+The pattern syntax is:
+ ((HEAD . ARGS) . BODY)
+The list of patterns is searched for a HEAD `eq' to the car of
+VALUE. If one is found, the BODY is executed with ARGS bound to the
+corresponding values in the CDR of VALUE."
+ (let ((operator (gensym "op-"))
+ (operands (gensym "rand-"))
+ (tmp (gensym "tmp-")))
+ `(let* ((,tmp ,value)
+ (,operator (car ,tmp))
+ (,operands (cdr ,tmp)))
+ (case ,operator
+ ,@(loop for (pattern . body) in patterns collect
+ (if (eq pattern t)
+ `(t , at body)
+ (destructuring-bind (op &rest rands) pattern
+ `(,op (destructuring-bind ,rands ,operands
+ , at body)))))
+ ,@(if (eq (caar (last patterns)) t)
+ '()
+ `((t (error "destructure-case failed: ~S" ,tmp))))))))
+
+;;; Taken from Alexandria (which is Public Domain, or BSD.)
+
+(define-condition simple-style-warning (simple-warning style-warning)
+ ())
+
+(defun simple-style-warn (format-control &rest format-args)
+ (warn 'simple-style-warning
+ :format-control format-control
+ :format-arguments format-args))
+
+(define-condition simple-program-error (simple-error program-error)
+ ())
+
+(defun simple-program-error (message &rest args)
+ (error 'simple-program-error
+ :format-control message
+ :format-arguments args))
+
+(defun required-argument (&optional name)
+ "Signals an error for a missing argument of NAME. Intended for
+use as an initialization form for structure and class-slots, and
+a default value for required keyword arguments."
+ (error "Required argument ~@[~S ~]missing." name))
+
+(defun ensure-list (list)
+ "If LIST is a list, it is returned. Otherwise returns the list
+designated by LIST."
+ (if (listp list)
+ list
+ (list list)))
+
+(declaim (inline ensure-function)) ; to propagate return type.
+(declaim (ftype (function (t) (values function &optional))
+ ensure-function))
+(defun ensure-function (function-designator)
+ "Returns the function designated by FUNCTION-DESIGNATOR:
+if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
+it must be a function name and its FDEFINITION is returned."
+ (if (functionp function-designator)
+ function-designator
+ (fdefinition function-designator)))
+
+(defun parse-body (body &key documentation whole)
+ "Parses BODY into (values remaining-forms declarations doc-string).
+Documentation strings are recognized only if DOCUMENTATION is true.
+Syntax errors in body are signalled and WHOLE is used in the signal
+arguments when given."
+ (let ((doc nil)
+ (decls nil)
+ (current nil))
+ (tagbody
+ :declarations
+ (setf current (car body))
+ (when (and documentation (stringp current) (cdr body))
+ (if doc
+ (error "Too many documentation strings in ~S." (or whole body))
+ (setf doc (pop body)))
+ (go :declarations))
+ (when (and (listp current) (eql (first current) 'declare))
+ (push (pop body) decls)
+ (go :declarations)))
+ (values body (nreverse decls) doc)))
+
+(defun parse-ordinary-lambda-list (lambda-list)
+ "Parses an ordinary lambda-list, returning as multiple values:
+
+ 1. Required parameters.
+ 2. Optional parameter specifications, normalized into form (NAME INIT SUPPLIEDP)
+ where SUPPLIEDP is NIL if not present.
+ 3. Name of the rest parameter, or NIL.
+ 4. Keyword parameter specifications, normalized into form ((KEYWORD-NAME NAME) INIT SUPPLIEDP)
+ where SUPPLIEDP is NIL if not present.
+ 5. Boolean indicating &ALLOW-OTHER-KEYS presence.
+ 6. &AUX parameter specifications, normalized into form (NAME INIT).
+
+Signals a PROGRAM-ERROR is the lambda-list is malformed."
+ (let ((state :required)
+ (allow-other-keys nil)
+ (auxp nil)
+ (required nil)
+ (optional nil)
+ (rest nil)
+ (keys nil)
+ (aux nil))
+ (labels ((simple-program-error (format-string &rest format-args)
+ (error 'simple-program-error
+ :format-control format-string
+ :format-arguments format-args))
+ (fail (elt)
+ (simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S"
+ elt lambda-list))
+ (check-variable (elt what)
+ (unless (and (symbolp elt) (not (constantp elt)))
+ (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S"
+ what elt lambda-list)))
+ (check-spec (spec what)
+ (destructuring-bind (init suppliedp) spec
+ (declare (ignore init))
+ (check-variable suppliedp what)))
+ (make-keyword (name)
+ "Interns the string designated by NAME in the KEYWORD package."
+ (intern (string name) :keyword)))
+ (dolist (elt lambda-list)
+ (case elt
+ (&optional
+ (if (eq state :required)
+ (setf state elt)
+ (fail elt)))
+ (&rest
+ (if (member state '(:required &optional))
+ (setf state elt)
+ (progn
+ (break "state=~S" state)
+ (fail elt))))
+ (&key
+ (if (member state '(:required &optional :after-rest))
+ (setf state elt)
+ (fail elt)))
+ (&allow-other-keys
+ (if (eq state '&key)
+ (setf allow-other-keys t
+ state elt)
+ (fail elt)))
+ (&aux
+ (cond ((eq state '&rest)
+ (fail elt))
+ (auxp
+ (simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S"
+ elt lambda-list))
+ (t
+ (setf auxp t
+ state elt))
+ ))
+ (otherwise
+ (when (member elt '#.(set-difference lambda-list-keywords
+ '(&optional &rest &key &allow-other-keys &aux)))
+ (simple-program-error
+ "Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S"
+ elt lambda-list))
+ (case state
+ (:required
+ (check-variable elt "required parameter")
+ (push elt required))
+ (&optional
+ (cond ((consp elt)
+ (destructuring-bind (name &rest tail) elt
+ (check-variable name "optional parameter")
+ (if (cdr tail)
+ (check-spec tail "optional-supplied-p parameter")
+ (setf elt (append elt '(nil))))))
+ (t
+ (check-variable elt "optional parameter")
+ (setf elt (cons elt '(nil nil)))))
+ (push elt optional))
+ (&rest
+ (check-variable elt "rest parameter")
+ (setf rest elt
+ state :after-rest))
+ (&key
+ (cond ((consp elt)
+ (destructuring-bind (var-or-kv &rest tail) elt
+ (cond ((consp var-or-kv)
+ (destructuring-bind (keyword var) var-or-kv
+ (unless (symbolp keyword)
+ (simple-program-error "Invalid keyword name ~S in ordinary ~
+ lambda-list:~% ~S"
+ keyword lambda-list))
+ (check-variable var "keyword parameter")))
+ (t
+ (check-variable var-or-kv "keyword parameter")
+ (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv))))
+ (if (cdr tail)
+ (check-spec tail "keyword-supplied-p parameter")
+ (setf tail (append tail '(nil))))
+ (setf elt (cons var-or-kv tail))))
+ (t
+ (check-variable elt "keyword parameter")
+ (setf elt (list (list (make-keyword elt) elt) nil nil))))
+ (push elt keys))
+ (&aux
+ (if (consp elt)
+ (destructuring-bind (var &optional init) elt
+ (declare (ignore init))
+ (check-variable var "&aux parameter"))
+ (check-variable elt "&aux parameter"))
+ (push elt aux))
+ (t
+ (simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list)))))))
+ (values (nreverse required) (nreverse optional) rest (nreverse keys)
+ allow-other-keys (nreverse aux))))
\ No newline at end of file
More information about the snow-cvs
mailing list