[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Thu Mar 23 18:25:24 UTC 2006
Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv11130
Modified Files:
Celtk.lisp ltktest-cells-inside.lisp menu.lisp textual.lisp
Log Message:
Final touches on Celtk, the ltktest-cells-inside demo, and the doc in ltktest-cells-inside.lisp.
--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/23 04:22:08 1.4
+++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/23 18:25:24 1.5
@@ -75,37 +75,54 @@
;;; - the executions rule is true obfuscated code. It manages to reset the count to zero
;;; on repeated (setf ... 20)'s because on the second repetition we know we will hit the rule
;;; with repeat non-null (20, in fact) and the ephemeral executed will be nil (because it is
-;;; only non-nil during propagation of (setf (executed...) t).
+;;; only non-nil during propagation of (setf (executed...) t). not for Cell noobs.
;;;
;;; - holy toledo. The /rule/ for after-factory sends the after command to Tk itself! I could just
;;; return a list of the delay and the callback and have an observer dispatch it, but it would
;;; have to so so exactly as the rule does, by dropping it in the deferred client queue.
-;;; so do it in the rule, I decide.
+;;; In a sense I am starting here to leverage Cells3 queues to simplify things. Mind you, if
+;;; Timer evolves to where we let the client write its own after factory, we might want to
+;;; factor out the actual dispatch into an observer to make it transparent (assuming that is
+;;; not why they are supplying their own after-factory.
+;;;
+;;; Timer is totally a work-in-progress with much development ahead.
+;;;
(defmodel timer ()
((id :cell nil :initarg :id :accessor id :initform nil
- :documentation "We use this as well as a flag that an AFTER is outstanding")
- (tag :cell nil :initarg :tag :accessor tag :initform :anon)
- (state :initarg :state :accessor state :initform (c-in :on))
- (action :initform nil :initarg :action :accessor action)
- (delay :initform 0 :initarg :delay :accessor delay)
- (repeat :initform (c-in nil) :initarg :repeat :accessor repeat :unchanged-if 'never-unchanged)
- (executed :cell :ephemeral :initarg :executed :accessor executed :initform (c-in nil))
+ :documentation "Assigned by TCL after each AFTER issued. Use to cancel.")
+ (tag :cell nil :initarg :tag :accessor tag :initform :anon
+ :documentation "A debugging aid")
+ (state :initarg :state :accessor state :initform (c-in :on)
+ :documentation "Turn off to stop, regardless of REPEAT setting")
+ (action :initform nil :initarg :action :accessor action
+ :documentation "A function (to which the timer is passed) invoked by when the TCL AFTER executes")
+ (delay :initform 0 :initarg :delay :accessor delay
+ :documentation "Millisecond interval supplied as is to TCL AFTER")
+ (repeat :initform (c-in nil) :initarg :repeat :accessor repeat :unchanged-if 'never-unchanged
+ :documentation "t = run continuously, nil = pause, a number N = repeat N times")
+ (executed :cell :ephemeral :initarg :executed :accessor executed :initform (c-in nil)
+ :documentation "Internal: set after an execution")
(executions :initarg :executions :accessor executions
+ :documentation "Number of times timer has had its action run since the last change to the repeat slot"
:initform (c? (if (null (^repeat))
- 0
+ 0 ;; ok, repeat is off, safe to reset the counter here
(if (^executed)
- (1+ .cache )
- 0))))
- (after-factory :initform (c? (when (and (eq (^state) :on)
- (let ((execs (^executions))) ;; odd reference just to establish dependency when repeat is t
- (bwhen (rpt (^repeat))
- (or (eql rpt t)
- (< execs rpt)))) ;; it better be a number
- (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters
- (setf (id self) (after (^delay) (lambda ()
- (funcall (^action) self)
- (setf (^executed) t)))))))))))
+ (1+ (or .cache 0)) ;; obviously (.cache is the prior value, and playing it safe in case unset)
+ 0)))) ;; hunh? executed is ephemeral. we are here only if repeat is changed, so reset
+
+ (after-factory
+ :documentation "Pure implementation"
+ :initform (c? (bwhen (rpt (when (eq (^state) :on)
+ (^repeat)))
+ (when (or (zerop (^executions)) (^executed)) ;; dispatch initially or after an execution
+ (when (if (numberp rpt)
+ (< (^executions) rpt)
+ rpt) ;; a little redundant since bwhen checks that rpt is not nil
+ (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters
+ (setf (id self) (after (^delay) (lambda ()
+ (funcall (^action) self)
+ (setf (^executed) t))))))))))))
(defobserver timers ((self tk-object) new-value old-value)
--- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/23 04:22:08 1.4
+++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/23 18:25:24 1.5
@@ -4,6 +4,12 @@
The comments throughout this source file cover two broad topics:
How is programming with Celtk different from LTk?
+
+Contrast the code below with the excellent ltktest "classic" in ltk.lisp to
+see how Celtk programming is different.
+
+Second topic:
+
How is programming with Cells different from without Cells?
Those questions are different because not everything different about Celtk
@@ -11,6 +17,11 @@
The pattern will be to have explanatory comments appear after the explained code.
+n.b. The paint is very fresh on Celtk, so if something like the Timer class looks
+dumb, well, it may be. Example: the scroller class only scrolls a canvas (well, I have not tried
+supplying a frame for the canvas slot, maybe it would work, but the slot name at least is
+certainly wrong (or the class should be canvas-scroller).
+
|#
#+test-ltktest
(progn
@@ -21,23 +32,25 @@
; - make .x the -textvariable of .y
; - set .x to "Hi, Mom"
;
- ; Tk does not like Step 3 going before Step 2. Unfortunately, in a declarative paradigm
- ; one does not specify in what order different things should happen, one just specifies
- ; the things we want to have happen. That is a big win when it works. But when it did not
- ; I created the concept of a so-called "client queue" where client-code could store
- ; order-sensitive tasks, and then allowed the client also to specify the handler for
+ ; Tk does not like Step 3 going before Step 2. That is, .y will not learn about "Hi, Mom.".
+ ; Unfortunately, in a declarative paradigm one does not specify in what order different
+ ; things should happen, one just specifies the things we want to have happen. That is
+ ; a big win when it works. But when it did not work for Tk I added to Cells the concept
+ ; of a "client queue" where client-code could store
+ ; order-sensitive tasks, also allowing the client to specify the handler for
; that queue. This handler gets called at just the right time in the larger scheme of
- ; state propagation one needs for data integrity. Whassat?
+ ; state propagation one needs for data integrity. What is that?
;
- ; Data integrity: when the overall data model gets perturbed by a SETF by imperative code
- ; (usually processing an event loop) of some datapoint X , we need:
+ ; Data integrity: when the overall data model gets perturbed by imperative code
+ ; (such as code processing an event loop) executing a SETF of some datapoint X , we want
+ ; these requirements satisfied:
;
- ; - all state computed off X (directly or indirectly through some intermediate state) must be recomputed;
- ; - no recomputation can use datapoints not current with the new value of X;
- ; - when invoking client observers to process a change in a datapoint, no observer can use
- ; any datapoint not current with X; and a corrollary:
- ; - should a client observer itself want to SETF a datapoint Y, all the above must
- ; happen not just with values current with X, but also current with the value of Y /prior/
+ ; - all state computed off X (directly or indirectly through some intermediate datapoint) must be recomputed;
+ ; - recomputations must see only datapoint values current with the new value of X. This must
+ ; work transparently, ie, datapoint accessors are responsible for returning only current values;
+ ; - similarly, client observers ("on change" callbacks) must see only values current with the new value of X
+ ; - a corrollary: should a client observer SETF a datapoint Y, all the above must
+ ; happen with values current not just with X, but also with the value of Y /prior/
; to the intended change to Y.
;
; To achieve the above, Cells2 and now Cells3 have taken to using FIFO "unfinished business" queues
@@ -56,8 +69,19 @@
; automatically by the Cells engine. See DEFOBSERVER.
(defmodel ltktest-cells-inside (window)
- ()
+ ((entry-warning :reader entry-warning
+ :initform (c? (bwhen (bad-chars (loop for c across (fm!v :entry)
+ when (digit-char-p c)
+ collect c))
+ (format nil "Please! No digits! I see ~a!!" bad-chars)))
+ ;
+ ; By the time I decided to add this demo I already had a long discussion under the get! and set! buttons, so
+ ; check those out for details.
+ ;
+ :documentation "Demonstrate live tracking of entry edit"))
+
(:default-initargs
+ :id :ltk-test
:kids (c?
; c? has one hell of an expansion. In effect one gets:
; - a first-class anonymous function with the expected body, which will have access to
@@ -65,25 +89,25 @@
; computed value, if any
; - guaranteed recomputation when the value of any other cell used in the computation changes
;
- ; The abbreviation-challenged use c-formula instead of c?, with different syntax I do not recall
+ ; If the abbreviation bothers you, look up c-formula.
;
(the-kids
;
; Cells GUIs get a lot of mileage out of the family class, which is perfect
- ; for graphical hierarchies. The deets of the-kids are of negligible interest.
+ ; for graphical hierarchies. "the-kids" does not do much, btw.
;
(ltk-test-menus) ;; hiding some code. see defun below for deets
(mk-scroller
;
; These "mk-" functions do nothing but expand into (make-instance 'scroller <the initarg list>).
- ; Where you see, say, mk-button-ex (a) I am poking fun at Microsoft naming of second generation
+ ; Where you see, say, mk-button-ex I am (a) poking fun at Microsoft naming of second generation
; library code that did not want to break existing code and (b) adding a little more value (just
; inspect the macro source to see how).
;
:packing (c?pack-self "-side top -fill both -expand 1")
;
; Here is an example of how the Family class helps. The above is one of only two packing
- ; statements need to recreate the ltktest demo. Other packing is handled via two
+ ; statements needed to recreate the ltktest demo. Other packing is handled via two
; slots in an inline-mixin class for various family subclasses, kids-layout and
; kids-packing. The latter pulls any packing parameters and all kids into one
; big pack statement kicked off by an observer on that slot. See the inline-mixin
@@ -105,7 +129,7 @@
; first row parameter is a string, it knows to make a labelframe instead of plain frame)
; The other thing it does, by forcing row parameters into a sub-list as the first argument,
; is let the programmer then just list other widgets (see next) which are understood to
- ; be subwidgets contained (packed or gridded) within the frame.
+ ; be kids/subwidgets contained (packed or gridded) within the frame.
;
(mk-row (:borderwidth 2 :relief 'sunken)
(mk-label :text "Rotation:")
@@ -122,12 +146,15 @@
; anywhere in the tree.)
;
; OK, now what is going on here? The above command starts the canvas display
- ; spinning, by tweaking the "repeat" slot of a "moire" (new ad hoc class) object
- ; I created to render the pretty design from
+ ; spinning, by tweaking (via the (setf moire-spin) defun below) the "repeat" slot of
+ ; an ad hoc "moire" class object created to render the pretty design from
; ltktest. How it accomplishes that will be explained below in the moire class
; definition.
;
(mk-button-ex ("Stop" (setf (moire-spin (fm^ :moire-1)) nil))))
+ ;
+ ; ditto
+ ;
(mk-button-ex ("Hallo" (format T "~&Hallo")))
@@ -148,10 +175,49 @@
;
; Thus each class uses md-value to hold something different, but in all cases it is
; the current value of whatever the instance of that class is understood to hold.
+ ;
+ ; The interesting question is, how does the md-value slot of the Lisp instance stay
+ ; current with the text being edited in the Tk entry widget? Here we have a fundamental
+ ; difference between Ltk and Celtk. Ltk lets Tk take care of everything, including
+ ; storing the data. eg, (text my-entry) is an accessor call that asks Tk the value of
+ ; the -text configuration for the Tk instance mirrored by my-entry. There is no text
+ ; slot in the Lisp entry instance. But Cells works
+ ; by having datapoints watching other datapoints, so we want data in the Lisp domain
+ ; changing automatically as it changes on the TK side (such as when the user is actually
+ ; typing in the entry widget). See the entry class to see how it uses the TCL "trace write"
+ ; mechanism to keep the Lisp md-value slot abreast of the Tk entry text configuration
+ ; keystroke by keystroke.
+ ;
+ ; I just added the entry-value slot above to demonstrate the mechanism in action. Click
+ ; on the entry widget and type "abc123", then delete the 3, 2, and 1, keeping an eye
+ ; on standard output.
;
- (mk-button-ex ("set!" (setf (fm^v :entry) "test of set"))))))))
+ (mk-button-ex ("set!" (setf (fm^v :entry) "test of set")))
+ ;
+ ; In Ltk one would SETF (text my-entry) and the
+ ; SETF method would communicate with Tk to make the change to the Tk widget -text
+ ; configuration. In Celtk, the md-value slot of the entry gets changed (possibly
+ ; triggering other slots to update, which is why we do not just talk to Tk) and
+ ; then that value gets propagated to Tk via "set <widget path> <value>". Because
+ ; the textVariable for every entry is the entry itself, the text of the entry
+ ; then changes. If that sounds weird, what we are actually doing is tapping into
+ ; Tk to a large degree taking the same approach as Cells does with the md-value
+ ; slot: in Cells, we think of model instances as wrapping some model-specific
+ ; value, which is held in the md-value slot of the model instance. Tk simply
+ ; allows a widget path to be a global variable. Furthermore, as the company name
+ ; ActiveState suggests, Tk also provides automatic propagation: change the
+ ; variable, and anyone with that as its textVariable also changes.
+ )))))
-
+(defobserver entry-warning ()
+ ;
+ ; This demonstrates ones ability to track the text in a Tk entry while it is being
+ ; edited. As you type you should see the changing values in standard output
+ ;
+ (if new-value
+ (format t "~&User, we have a problem: ~a" new-value)
+ (when old-value
+ (format t "~&That looks better: ~a" (fm!v :entry)))))
(defmodel ltk-test-canvas (canvas)
()
@@ -188,8 +254,8 @@
;
; here is a limitation with the declarative paradigm. pop-up menus are free to float about
; unpacked in any parent. One just needs to remember the name of the menu widget to
- ; pass it to the pop-up function. So imperative code like ltktest original can just make the menus
- ; saving their name in a local variable and then refer to them in a callback to pop them up.
+ ; pass it to the pop-up function. So imperative code like ltktest "classic" can just make the menus
+ ; saving their name in a closed-over local variable and then refer to them in a callback to pop them up.
;
; in the declarative paradigm we need a slot (defined for any widget or item class) in which
; to build and store such menus:
@@ -214,30 +280,48 @@
:anchor "nw"
:text "Ltk Demonstration")
(make-kid 'moire :id :moire-1)))))
+ ;
+ ; we give /this/ widget a specific ID so other rules can look it up, as
+ ; discussed above when explaining fm^.
(defmodel moire (line)
- ((rotx :initarg :rotx :accessor rotx :initform (c-in 0)))
+ ((angle-1 :initarg :angle-1 :accessor angle-1 :initform (c-in 0)))
(:default-initargs
:timers (c? (list (make-instance 'timer
- :state (c-in :on)
- :repeat (c-in nil)
- :delay 25 ;; milliseconds since this gets passed to TK after
- :action (lambda (timer)
- (when (eq (state timer) :on)
- (incf (^rotx)))))))
- :coords (c? (let* ((angle (* 0.1 (^rotx)))
- (angle2 (* 0.3 angle))
- (wx (sin (* 0.1 angle))))
+ ;
+ ; it occurred to me that it might be useful to build a timer utility
+ ; around the TCL after command. See the class definition of timer
+ ; for the fireworks (in terms of Cells) that resulted
+ ;
+ :repeat (c-in nil)
+ :delay 25 ;; milliseconds since this gets passed unvarnished to TK after
+ :action (lambda (timer)
+ (when (eq (state timer) :on)
+ (incf (^angle-1) 0.1))))))
+ :coords (c? (let* ((angle-2 (* 0.3 (^angle-1)))
+ (wx (sin (* 0.1 (^angle-1)))))
(loop for i below 100
- for w = (+ angle (* i 2.8001))
- for x = (+ (* 50 (sin angle2)) 250 (* 150 (sin w) (1+ wx)))
- for y = (+ (* 50 (cos angle2)) 200 (* 150 (cos w)))
+ for w = (+ (^angle-1) (* i 2.8001))
+ for x = (+ (* 50 (sin angle-2)) 250 (* 150 (sin w) (1+ wx)))
+ for y = (+ (* 50 (cos angle-2)) 200 (* 150 (cos w)))
nconcing (list x y))))))
(defun (setf moire-spin) (repeat self)
- (setf (repeat (car (timers self))) repeat))
+ (setf (repeat (car (timers self))) repeat)) ;; just hiding the implementation
(defun ltk-test-menus ()
+ ;
+ ; The only difference is that the menu structure as seen by the user
+ ; is apparent here, which might help some when reorganizing menus.
+ ;
+ ; Well, another thing which happens not to be visible here... hang on.
+ ; OK, I just made the Save menu item contingent upon there being no
+ ; entry-warning. As you add/remove all digits (considered invalid for
+ ; demonstration purposes) the menu item becomes available/unavailable
+ ; appropriately.
+ ;
+ ; This is the kind of thing that Cells is good for.
+ ;
(mk-menubar
:kids (c? (the-kids
(mk-menu-entry-cascade-ex (:label "File")
@@ -246,6 +330,8 @@
(lambda () (format t "~&Load pressed")))))
(mk-menu-entry-command :label "Save"
+ :state (c? (if (entry-warning (fm^ :ltk-test))
+ :disabled :normal))
:command (c? (tk-callback .tkw 'save
(lambda () (format t "~&Save pressed")))))
(mk-menu-entry-separator)
@@ -260,7 +346,13 @@
(lambda () (format t "~&Png pressed"))))))
(mk-menu-entry-separator)
(mk-menu-entry-command :label "Quit"
- :accelerator "<Alt-q>"
+ :accelerator "Alt-q"
+ ;
+ ; check out the observer on the accelerator slot of the class menu-entry-usable
+ ; to see how Celtk fills in a gap in Tk: accelerators should work just by
+ ; declaring them to the menu widget, it seems to me. In Celtk, they do.
+ ;
:underline 1
:command "exit"))))))
+
--- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/22 18:50:08 1.3
+++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/23 18:25:24 1.4
@@ -140,7 +140,7 @@
(call-next-method)
(with-integrity (:client '(:bind nil))
(when new-value
- (tk-format-now "bind . ~a {~a invoke ~a}" new-value (path (upper self menu)) (index self)))))
+ (tk-format-now "bind . <~a> {~a invoke ~a}" new-value (path (upper self menu)) (index self)))))
(deftk menu-entry-cascade (selector family menu-entry-usable)
--- /project/cells/cvsroot/Celtk/textual.lisp 2006/03/22 05:26:22 1.2
+++ /project/cells/cvsroot/Celtk/textual.lisp 2006/03/23 18:25:24 1.3
@@ -68,7 +68,7 @@
(:default-initargs
:id (gentemp "ENT")
:textvariable (c? (^path))
- :md-value (c-in "<your string here>")))
+ :md-value (c-in "")))
(defmethod md-awaken :after ((self entry))
(tk-format `(:trace ,self) "trace add variable ~a write \"trc2 ~a\""
More information about the Cells-cvs
mailing list