Update of /project/cells/cvsroot/cells/tutorial
In directory clnet:/tmp/cvs-serv19862/tutorial
Added Files:
01-lesson.lisp 01a-dataflow.lisp 01b-change-handling.lisp
01c-cascade.lisp 02-lesson.lisp 03-ephemeral.lisp test.lisp
tutorial.lpr
Log Message:
Beginnings of tutorial/porting suite of demonstration/example/regression test code. Also, a fix to core Cells so rules can happen to return multiple values (say by using ROUND as the last form) without tripping over Synapse-handling.
--- /project/cells/cvsroot/cells/tutorial/01-lesson.lisp 2006/05/30 02:47:45 NONE
+++ /project/cells/cvsroot/cells/tutorial/01-lesson.lisp 2006/05/30 02:47:45 1.1
(defmacro cells::ct-assert (form &rest stuff)
`(progn
(print `(attempting ,',form))
(assert ,form () "Error with ~a >> ~a" ',form (list ,@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.
--- /project/cells/cvsroot/cells/tutorial/01a-dataflow.lisp 2006/05/30 02:47:45 NONE
+++ /project/cells/cvsroot/cells/tutorial/01a-dataflow.lisp 2006/05/30 02:47:45 1.1
(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
--- /project/cells/cvsroot/cells/tutorial/01b-change-handling.lisp 2006/05/30 02:47:45 NONE
+++ /project/cells/cvsroot/cells/tutorial/01b-change-handling.lisp 2006/05/30 02:47:45 1.1
#| 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))))
--- /project/cells/cvsroot/cells/tutorial/01c-cascade.lisp 2006/05/30 02:47:45 NONE
+++ /project/cells/cvsroot/cells/tutorial/01c-cascade.lisp 2006/05/30 02:47:45 1.1
#| 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.
[Actually, I see I need to make this a little deeper, since area has
a direct dependency on width. Not tonight. :)]
|#
(defpackage #:tu-depth (:use :cl :cells))
(in-package #:tu-depth)
(defmodel rectangle ()
((area :initarg :area :accessor area
:initform (c? (print :compue-area)
(* (len self)(width self))))
(len :initarg :len :accessor len
:initform (c? (print :compute-len)
(* 2 (width self))))
(width :initarg :width :accessor width
:initform (c? (print :compute-width)
(floor (len self) 2)))))
#+test
(let ((r (make-instance 'rectangle :len (c-in 42))))
(cells::ct-assert (eql 21 (width r)))
(cells::ct-assert (eql (* 21 42) (area r)))
(cells::ct-assert (= 1000 (setf (len r) 1000)))
(cells::ct-assert (eql 500000 (area r))))
--- /project/cells/cvsroot/cells/tutorial/02-lesson.lisp 2006/05/30 02:47:45 NONE
+++ /project/cells/cvsroot/cells/tutorial/02-lesson.lisp 2006/05/30 02:47:45 1.1
#| 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))
--- /project/cells/cvsroot/cells/tutorial/03-ephemeral.lisp 2006/05/30 02:47:45 NONE
+++ /project/cells/cvsroot/cells/tutorial/03-ephemeral.lisp 2006/05/30 02:47:45 1.1
(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.
|#
--- /project/cells/cvsroot/cells/tutorial/test.lisp 2006/05/30 02:47:45 NONE
+++ /project/cells/cvsroot/cells/tutorial/test.lisp 2006/05/30 02:47:45 1.1
;; -*- 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 ,@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)))--- /project/cells/cvsroot/cells/tutorial/tutorial.lpr 2006/05/30 02:47:45 NONE
+++ /project/cells/cvsroot/cells/tutorial/tutorial.lpr 2006/05/30 02:47:45 1.1
;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*-
(in-package :cg-user)
(defpackage :COMMON-GRAPHICS-USER)
(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"))
:projects (list (make-instance 'project-module :name "..\\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)
[12 lines skipped]
