Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv14123

Modified Files: demos.lisp entry.lisp gears.lisp menu.lisp multichoice.lisp timer.lisp Added Files: ltktest-ci.lisp Removed Files: gears-demo.lisp ltktest-cells-inside.lisp Log Message:

--- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/04 10:06:37 1.10 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/04 21:26:23 1.11 @@ -25,8 +25,8 @@

(defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window ;; 'one-button - ;;'ltktest-cells-inside - 'gears-demo + 'ltktest-cells-inside + ;;'gears-demo ))

(defmodel one-button (window) --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/03 08:20:49 1.2 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/04 21:26:23 1.3 @@ -50,10 +50,9 @@ (setf (gethash '|write| (event-handlers self)) (lambda (self event-type) ;; &rest args) (declare (ignorable event-type)) - (with-integrity (:change) - (let ((new-value (tk-eval-var (^path)))) + (let ((new-value (tk-eval-var (^path)))) (unless (string= new-value (^md-value)) - (setf (^md-value) new-value)))))))) + (setf (^md-value) new-value)))))))

;;; /// this next replicates the handling of tk-mirror-variable because ;;; those leverage the COMMAND mechanism, which entry lacks --- /project/cells/cvsroot/Celtk/gears.lisp 2006/05/04 10:06:37 1.5 +++ /project/cells/cvsroot/Celtk/gears.lisp 2006/05/04 21:26:23 1.6 @@ -1,3 +1,7 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; gears.lisp --- Celtk/Togl version of cl-opengl Lisp version of gears.c (GLUT Mesa demos). +;;; +;;; Simple program with rotating 3-D gear wheels.

(in-package :celtk-user)

@@ -33,13 +37,13 @@ (mk-button-ex ("Remove" (when (plusp (gear-ct .tkw)) (decf (gear-ct .tkw))))) (mk-entry :id :vtime - :md-value (c-in "100")) + :md-value (c-in "10")) (mk-button-ex (" Quit " (tk-eval "destroy .")))) (make-instance 'gears :fm-parent *parent* :width 400 :height 400 :timer-interval (c? (let ((n$ (md-value (fm-other :vtime)))) - (format nil "~a" (or (parse-integer n$ :junk-allowed t) 0)))) + (format nil "~a" (max 1 (or (parse-integer n$ :junk-allowed t) 0))))) :double 1 ;; "yes" :bindings (c? (list (list '|<1>| (lambda (self event root-x root-y) @@ -50,8 +54,7 @@ (list '|<B1-Motion>| (lambda (self event root-x root-y) (declare (ignore event)) - (with-integrity (:change) - (RotMove self root-x root-y)) + (RotMove self root-x root-y) 0) "%X %Y")))))))))

@@ -67,17 +70,36 @@ (setf *xangle* (+ *xangle0* (- x *startx*))) (setf *yangle* (+ *yangle0* (- y *starty*))) (setf (rotx self) *xangle*) - (setf (roty self) *yangle*)) + (assert (eql *xangle* (rotx self))) + (setf (roty self) *yangle*) + (trc "RotMove x y" *xangle* *yangle*))

(defconstant +pif+ (coerce pi 'single-float))

(defmodel gears (togl) - ((rotx :initform (c-in 0.2) :accessor rotx :initarg :rotx) - (roty :initform (c-in 0.5) :accessor roty :initarg :roty) - (rotz :initform (c-in 0.8) :accessor rotz :initarg :rotz) - (gear1 :accessor gear1 :initform (c-in nil)) - (gear2 :accessor gear2 :initform (c-in nil)) - (gear3 :accessor gear3 :initform (c-in nil)) + ((rotx :initform (c-in 40) :accessor rotx :initarg :rotx) + (roty :initform (c-in 25) :accessor roty :initarg :roty) + (rotz :initform (c-in 10) :accessor rotz :initarg :rotz) + (gear1 :initarg :gear1 :accessor gear1 + :initform (c_? (trc "making list!!!!! 1") + (let ((dl (gl:gen-lists 1))) + (gl:with-new-list (dl :compile) + (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) + (draw-gear 1.0 4.0 1.0 20 0.7)) + dl))) + (gear2 :initarg :gear2 :accessor gear2 + :initform (c_? (let ((dl (gl:gen-lists 1))) + (gl:with-new-list (dl :compile) + (gl:material :front :ambient-and-diffuse #(0.0 0.8 0.2 1.0)) + (draw-gear 0.5 2.0 2.0 10 0.7)) + dl))) + (gear3 :initarg :gear3 :accessor gear3 + :initform (c_? (let ((dl (gl:gen-lists 1))) + (gl:with-new-list (dl :compile) + (gl:material :front :ambient-and-diffuse #(0.2 0.2 1.0 1.0)) + (draw-gear 1.3 2.0 0.5 10 0.7)) + dl))) + (angle :initform (c-in 0.0) :accessor angle :initarg :angle) (frame-count :cell nil :initform 0 :accessor frame-count) (t0 :cell nil :initform 0 :accessor t0) @@ -87,9 +109,8 @@

(defmethod togl-timer-using-class ((self gears)) (trc nil "enter gear timer" self (togl-ptr self) (get-internal-real-time)) - (with-integrity (:change) - (incf (^angle) 2.0) - (Togl_PostRedisplay (togl-ptr self)))) + (incf (^angle) 2.0) + (Togl_PostRedisplay (togl-ptr self)))

(defmethod togl-reshape-using-class ((self gears)) (let ((width (Togl_width (togl-ptr self))) @@ -106,56 +127,38 @@

(defmethod togl-display-using-class ((self gears) &aux (scale (scale (upper self gears-demo)))) (declare (ignorable scale)) - (with-slots (rotx roty rotz angle gear1 gear2 gear3) - self - - (gl:clear-color 0 0 0 1) - (gl:clear :color-buffer-bit :depth-buffer-bit) - + + (gl:clear-color 0 0 0 1) + (gl:clear :color-buffer-bit :depth-buffer-bit) + + (gl:with-pushed-matrix + (gl:rotate (^rotx) 1 0 0) + (gl:rotate (^roty) 0 1 0) + (gl:rotate (^rotz) 0 0 1) + (gl:with-pushed-matrix - (gl:rotate rotx 1 0 0) - (gl:rotate roty 0 1 0) - (gl:rotate rotz 0 0 1) - - (gl:with-pushed-matrix ; gear1 (gl:translate -3 -2 0) - (gl:rotate angle 0 0 1) - (gl:call-list gear1)) - - (gl:with-pushed-matrix ; gear2 - (gl:translate 3.1 -2 0) - (gl:rotate (- (* -2 angle) 9) 0 0 1) - (gl:call-list gear2)) - - (gl:with-pushed-matrix ; gear3 - (gl:translate -3.1 4.2 0.0) - (gl:rotate (- (* -2 angle) 25) 0 0 1) - (gl:call-list gear3))) + (gl:rotate (^angle) 0 0 1) + (gl:call-list (^gear1)))

- (Togl_SwapBuffers (togl-ptr self)) + (gl:with-pushed-matrix + (gl:translate 3.1 -2 0) + (gl:rotate (- (* -2 (^angle)) 9) 0 0 1) + (gl:call-list (^gear2)))

- #+shhh (print-frame-rate self))) + (gl:with-pushed-matrix ; gear3 + (gl:translate -3.1 4.2 0.0) + (gl:rotate (- (* -2 (^angle)) 25) 0 0 1) + (gl:call-list (^gear3)))) + + (Togl_SwapBuffers (togl-ptr self)) + + #+shhh (print-frame-rate self))

(defmethod togl-create-using-class ((self gears)) (gl:light :light0 :position #(5.0 5.0 10.0 0.0)) (gl:enable :cull-face :lighting :light0 :depth-test) - - ;; gear 1 - (setf (^gear1) (gl:gen-lists 1)) - (gl:with-new-list ((^gear1) :compile) - (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) ; red - (draw-gear 1.0 4.0 1.0 20 0.7)) - - ;; gear 2 - (setf (^gear2) (gl:gen-lists 1)) - (gl:with-new-list ((^gear2) :compile) - (gl:material :front :ambient-and-diffuse #(0.0 0.8 0.2 1.0)) ; green - (draw-gear 0.5 2.0 2.0 10 0.7)) - ;; gear 3 - (setf (^gear3) (gl:gen-lists 1)) - (gl:with-new-list ((^gear3) :compile) - (gl:material :front :ambient-and-diffuse #(0.2 0.2 1.0 1.0)) ; blue - (draw-gear 1.3 2.0 0.5 10 0.7)) + (gl:material :front :ambient-and-diffuse #(0.8 0.1 0.0 1.0)) (gl:enable :normalize))

(defun draw-gear (inner-radius outer-radius width n-teeth tooth-depth) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/05/04 06:11:10 1.10 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/05/04 21:26:24 1.11 @@ -218,8 +218,7 @@ :on-command (lambda (self) (declare (ignore key args)) (trc nil "menu radio button command firing" self (^value) (upper self selector)) - (with-integrity (:change) - (setf (selection (upper self selector)) (^value)))))) + (setf (selection (upper self selector)) (^value)))))

(defmodel menu-radio-group (selector family) ((.md-name :cell nil :initform (gentemp "RG") :initarg :id)) @@ -276,8 +275,7 @@

(defobserver initial-value ((self popup-menubutton)) (when new-value - (with-integrity (:change self) - (setf (selection self) new-value)))) + (setf (selection self) new-value)))

(defmethod tk-output-selection ((self popup-menubutton) new-value old-value old-value-boundp) (declare (ignorable old-value old-value-boundp)) --- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/03 08:20:49 1.2 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/04 21:26:24 1.3 @@ -124,8 +124,7 @@

(defobserver initial-value ((self spinbox)) (when new-value - (with-integrity (:change) - (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value) - (setf (^md-value) new-value)))) + (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value) + (setf (^md-value) new-value)))

--- /project/cells/cvsroot/Celtk/timer.lisp 2006/05/03 08:20:49 1.2 +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/05/04 21:26:24 1.3 @@ -79,11 +79,10 @@

(on-command :reader on-command :initform (lambda (self) - (with-integrity (:change self) - (when (eq (^state) :on) + (when (eq (^state) :on) (assert (^action)) (funcall (^action) self) - (setf (^executed) t))))) + (setf (^executed) t)))) (after-factory :reader after-factory :initform (c? (bwhen (rpt (eko (nil ">>> repeat") (when (eq (^state) :on) (^repeat))))

--- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/04 21:26:24 NONE +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/04 21:26:24 1.1 #|

This software is Copyright (c) 2003, 2004, 2005, 2006 Peter Herth herth@peter-herth.de Parts Copyright (c) 2005 Thomas F. Burdick Parts Copyright (c) Cadence Design Systems, GmbH

Peter Herth grants you the rights to distribute and use this software as governed by the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL.

This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!! PROMINENT NOTICE !!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!! !!!!!!!!!!!!!!! !!!!!!!!!!!! This demo was translated to Cells !!!!!!!!!!!!!!! !!!!!!!!!!!! by ken Tilton on March 22, 2006. !!!!!!!!!!!!!!! !!!!!!!!!!!! !!!!!!!!!!!!!!! !!!!!!!!!!!! Original (ltktest) can be found !!!!!!!!!!!!!!! !!!!!!!!!!!! at the end of ltk.lisp !!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

|#

(in-package :celtk-user) #|

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. I won't say better, because some people prefer an imperative approach where they can have all the bricks laid out in front of them and sequence them manually one by one to get exactly what they want without thinking very hard. The declarative approach makes one think a little harder but in the end do less work as the responsibility for getting things to work falls on the engine behind the declarative interface.

Second topic:

How is programming with Cells different from without Cells?

Those questions are different because not everything different about Celtk depends on Cells.

Note: 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 (cells-reset 'tk-user-queue-handler) ; ; Tk is fussy about the order in which things happen. It likes: ; - create widgets .x and .y ; - make .x the -textvariable of .y ; - set .x to "Hi, Mom" ; ; 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. An underlying ; engine then runs around taking care of making that happen, without bothering the developer ; about how to do that. That includes deciding in what order to make those things happen. That is ; a big win when it works. When it did not work for Tk, and I could imagine the same thing ; coming up again in other situations (Tilton's Law: "The first time you run into something ; is just the first time you ran into it"), I added to Cells the concept of a "client queue", ; where client-code can store order-sensitive tasks. The client also can specify the handler for ; that queue, here 'tk-user-queue-handler. This handler (or the default FIFO handler) gets called ; at just the right time in the larger scheme of state propagation one needs for ; data integrity. What is that scheme? ; ; Data integrity: when the overall Cells data model gets perturbed by imperative code -- typically an ; event loop -- executing a SETF of some datapoint X, we want these requirements met: ; ; - recompute all and (for efficiency) only state computed off X (directly or indirectly through some intermediate datapoint); ; ; - recomputations, when they read other datapoints, must see only values current with the new value of X; ; ; - similarly, client observers ("on change" 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. ; ; To achieve the above, Cells2 and now Cells3 have taken to using FIFO "unfinished business" queues ; to defer things until The Right Time. Which brings us back to Tk. Inspect the source of ; tk-user-queue-handler and search the Celtk source for "with-integrity (:client" to see how Celtk ; manages to talk to Tk in the order Tk likes. And hack the function tk-format-now to have ; Celtk dump the TCL/Tk code being sent to wish during initialization, and notice how un-random it looks. You can ; then comment out the above specification of a Tk-savvy handler to see (a) the order that would have happened ; before Cells3 and (b) the demo collapse in a broken heap. ; ; But in short, with Cells3 we just add this requirement: ; ; - 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 ; (ctk:test-window 'ltktest-cells-inside))

; That is all the imperative code there is to Celtk application development, aside from widget commands, and those ; invariably (?) consist of a single setf. So where does the rest of the state change necessary to keep a GUI ; interface self-consistent get taken care of?

; Tk handles some of the driving imperative logic -- they call the company ActiveState for a reason -- and Celtk internals ; handle the rest. The application works via Cells rules reacting to change by computing new state for the application model, ; which operates on the outside world via observers (on-change callbacks) triggered ; automatically by the Cells engine. See DEFOBSERVER.

(defmodel ltktest-cells-inside (window) ()

(:default-initargs :id :ltk-test :kids (c? ; c? has quite an expansion. Functionally, one gets: ; - a first-class anonymous function with the expected body, which will have access to... ; - lexical variables self and .cache for the instance and prior computed value, if any ; - guaranteed recomputation when the value of any other cell /used in the most recent computation/ changes ; ; If the abbreviation c? alarms 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-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>) ; and supply the "parent" :initarg necessary in Family trees. ; ; 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 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 ; class to see how this works. ; ; See the scroller class to see some automation of grids (but this was my first experience ; with grids so look for that to get enhanced over time -- and later automation ; of the use of PLACE. ; :canvas (c? (make-kid 'ltk-test-canvas))) ;; hiding some code. see defmodel thereof below ; ; My bad. Scroller should not assume a canvas is the scrollee. To be refined. ;

(mk-row (:packing (c?pack-self "-side bottom")) ; ; Just expand mk-row to see what is going on. It is pretty neat in one respect: if the ; 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 kids/subwidgets contained by the frame. ; (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Rotation:") ; ; As with Ltk Classic, the Tk widget configurations become Lisp widget initializers, so ; the Tk doc documents Celtk. The advantage to the developer is that neither LTk nor ; Celtk introduce a new API to be mastered, widget-wise. ; (mk-button-ex ("Start" (setf (moire-spin (fm^ :moire-1)) t))) ; ; You were warned about mk-button-ex and its ilk above. Just expand or inspect to ; see what they do, which is pretty much just hide some boilerplate. ; ; fm^ is a wicked abbreviation for "search up the Family tree to find the widget ; with this ID". ie, The Family tree effectively becomes a namespace of IDs. I have a suite of ; routines that search the namespace by name so one widget can operate on or, ; more commonly, ask for the value of a slot of some specific widget known to ; be Out There somewhere. (Kids know their parents, so the search can reach ; anywhere in the tree.) ; ; OK, now what is going on here? The above command starts the canvas display ; 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"))) (mk-button-ex ("Welt!" (format T "~&Welt!"))) (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Test:") (mk-button-ex ("OK:" (setf (moire-spin (fm^ :moire-1)) 100)))) ; ; Cells initiata will be surprised to learn the above works twice even if the button is ; clicked twice in a row; Cells is about managing state change, and the second time through ; there is no change. But the system still reacts! See the Timer class for the shocking ; solution to this riddle. ; (mk-entry-numeric :id :point-ct :md-value (c-in "42") ; ; to help motivate "why Cells?" a little more, we deviate from ltktest 'classic" and ; start having the widgets take more interesting effect: The entry field now determines the number ; of points to generate for the canvas line item, which originally was fixed at 100. ; see the moire class for details. ; :num-parse (c? (eko ("numparse") ; ; (EKO is a utils-kt debug hack that prints a value along with arbitrary ; other info before returning the value to the inquirer) ; ; Here we supplement the standard entry-numeric parse rule with ; our own more stringent rule that knows about the moire task ahead. ; ; A vital point with this entry-numeric class (invented just now for ; this demo) is that Cells does not get in the way of CLOS. We are ; subclassing, using initforms, default-initargs, and, what I suspect is ; a big reason Cells are such a big win: different instances of the same ; class do not need to have the same rules for the same slot. Or even ; have rules at all; other instances can have a constant or be setffable ; from outside the model. ; (handler-case (let ((num (parse-integer (^md-value)))) (cond ((< num 2) (list (format nil "Yo, Euclid, at least two, not: ~a!!" num))) ((> num 200) (list (format nil "Bzzt! ~a points will not look so hot." num))) (t num))) (parse-error (c) (princ-to-string c))))) :background (c? (if (user-errors (fm! :point-ct)) "red" 'SystemButtonFace))) ;; TK won't allow "" as a way of saying "default color" ; ; As you edit the field, if you key in an invalid (non-digit) character, the background ; immediately turns red. Delete it and it reverts to the default. ; ; 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. Makes for nice, lightweight Lisp instances. 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 added the :user-errors rule above to demonstrate the mechanism in action. Click ; on the entry widget and type "123abc", then delete the alpha characters. The background ; color (as well as the File\Save menu item state) tracks the typing. ;

(mk-button-ex ("Print" (format t "~&User wants to see ~A points" (fm^v :point-ct)))) ; ; (fm^v :point-ct) -> (md-value (fm^ :point-ct)) ; ; The idea being that every Cells model object has an md-value slot bearing the value ; of the thing being modeled. Here, the entry widget is modelling a place for users ; to supply information to an application, and the md-value slot is a good place to ; keep that information. ; ; 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. ; (mk-button-ex ("Reset" (setf (fm^v :point-ct) "42"))) ; ; Driving home this point again, 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 ; the fact that Tk to a large degree takes the same approach as Cells does with md-value: ; 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. )))))

(defmodel ltk-test-canvas (canvas) () (:default-initargs :id :test-canvas :background (c? (or (selection (fm! :bkg (^menus))) 'SystemButtonFace)) ; ; we are taking the demo a little further to make it a little more real world than just ; printing to standard output. A point to make here is the decoupling of the menu from ; its application role, namely allowing the user to specify the background color of ; the spinning lines. The pop-up is now a radio-group menu that does not know how the ; choice it is maintaining will be used. It simply takes care of its business of allowing ; the user to choose exactly one color. Changes get propagated automatically by the Cells ; engine to any slot whose rule happens to read the radio-group selection slot. And the coding ; is transparent: just read the value. No need to write explicit code to subscribe, notify, ; or unsubscribe. ; :scroll-region '(0 0 500 400) :gridding "-row 0 -column 0 -sticky news" ; ; As with packing, Celtk tries to simplify life with Tk gridding. But that is achieved partly ; by automating things as with the kids-packing and kids-layout slots, and partly by staying ; out of the programmer's way and letting them specify actual Tk code to be passed unfiltered ; to Tk. The design choice here is to acknowledge that LTk and Celtk users really are still ; doing Tk programming; only some automation (and Lispification) is provided. ; ; This also simplifies Celtk since it just has to pass the Tk code along with "grid <path> " ; appended. ; :bindings (c? (list (list '|<1>| (lambda (self event root-x root-y) (declare (ignorable event root-x root-y))

; ; Stolen from the original. It means "when the left button is ; pressed on this widget, popup this menu where the button was pressed" ; The only difference is that here we get to specify this along with ; the rest of the configuration of this instance, whereas in the original ; the enabling code was just "out there" in a long sequence of other ; imperatives setting up this widget and that. ie, It is nice having ; everything about X collected in one place. In case you are wondering, ; an observer on the bindings slot passes the needed bindings to Tk ; via the client queue. ; (pop-up (^widget-menu :bkg-pop) root-x root-y)) "%X %Y")))

:menus (c? (the-kids ; ; we could just build the menu in the rule above for bindings and then close over the variable ; bearing the menu's Tk name in the binding callback in the call to pop-up, but I try to decompose ; these things in the event that the bindings become dynamic over time (esp. such that the rule to generate ; the binding list runs repeatedly) so we are not forever regenerating the same pop-up menu. ; premature optimization? well, it also makes the code clearer, and should the list of menus become ; variable over time this allows us to GC (via Tk "destroy") menus, so this is not so much about ; optimization as it is about Good Things happening to well-organized code. ; (mk-menu :id :bkg-pop :kids (c? (the-kids (mk-menu-radio-group :id :bkg :selection (c-in nil) ;; this will start us off with the Tk default :kids (c? (the-kids (mk-menu-entry-radiobutton :label "Crimson Tide" :value "red") (mk-menu-entry-radiobutton :label "Oak Tree Ribbon" :value "yellow") (mk-menu-entry-radiobutton :label "Sky" :value 'blue) (mk-menu-entry-radiobutton :label "Factory" :value 'SystemButtonFace)))))))))

:kids (c? (the-kids (mk-text-item :coords (list 10 10) :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) ((angle-1 :initarg :angle-1 :accessor angle-1 :initform (c-in 0)) (point-ct :initarg :point-ct :accessor point-ct :initform (c? (num-value (fm^ :point-ct))))) (:default-initargs :timers (c? (list (make-instance 'timer ; ; 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 t) :delay 1 ;; milliseconds since this gets passed unvarnished to TK after :action (lambda (timer) (declare (ignorable timer)) (incf (^angle-1) 0.1))))) :coords (c? (let ((angle-2 (* 0.3 (^angle-1))) (wx (sin (* 0.1 (^angle-1))))) (loop for i below (^point-ct) for w = (+ (^angle-1) (* i 2.8001)) for x = (+ (* 50 (sin angle-2)) 250 (* 150 (sin w) (1+ wx)))

[63 lines skipped]