/[cells]/Celtk/ltktest-ci.lisp
ViewVC logotype

Contents of /Celtk/ltktest-ci.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Sat Nov 4 20:53:08 2006 UTC (7 years, 5 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.10: +13 -13 lines
New "lite" versions of Celtk without all the Tk widgets, for PureCello
1 #|
2
3 This software is Copyright (c) 2003, 2004, 2005, 2006 Peter Herth <herth@peter-herth.de>
4 Parts Copyright (c) 2005 Thomas F. Burdick
5 Parts Copyright (c) Cadence Design Systems, GmbH
6
7 Peter Herth grants you the rights to distribute
8 and use this software as governed by the terms
9 of the Lisp Lesser GNU Public License
10 (http://opensource.franz.com/preamble.html),
11 known as the LLGPL.
12
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
19 !!!!!!!!!!!! PROMINENT NOTICE !!!!!!!!!!!!!!!
20 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
21 !!!!!!!!!!!! !!!!!!!!!!!!!!!
22 !!!!!!!!!!!! This demo was translated to Cells !!!!!!!!!!!!!!!
23 !!!!!!!!!!!! by ken Tilton on March 22, 2006. !!!!!!!!!!!!!!!
24 !!!!!!!!!!!! !!!!!!!!!!!!!!!
25 !!!!!!!!!!!! Original (ltktest) can be found !!!!!!!!!!!!!!!
26 !!!!!!!!!!!! at the end of ltk.lisp !!!!!!!!!!!!!!!
27 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
28 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
29
30 |#
31
32
33 (in-package :celtk-user)
34 #|
35
36 The comments throughout this source file cover two broad topics:
37
38 How is programming with Celtk different from LTk?
39
40 Contrast the code below with the excellent ltktest "classic" in ltk.lisp to
41 see how Celtk programming is different. I won't say better, because some people prefer an
42 imperative approach where they can have all the bricks laid out in front of them
43 and sequence them manually one by one to get exactly what they want without thinking
44 very hard. The declarative approach makes one think a little harder but in the end
45 do less work as the responsibility for getting things to work falls on the engine behind
46 the declarative interface.
47
48 Second topic:
49
50 How is programming with Cells different from without Cells?
51
52 Those questions are different because not everything different about Celtk
53 depends on Cells.
54
55 Note: explanatory comments appear after the explained code.
56
57 n.b. The paint is very fresh on Celtk, so if something like the Timer class looks
58 dumb, well, it may be. Example: the scroller class only scrolls a canvas (well, I have not tried
59 supplying a frame for the canvas slot, maybe it would work, but the slot name at least is
60 certainly wrong (or the class should be canvas-scroller).
61
62 |#
63 #+test-ltktest
64 (progn
65 (cells-reset 'tk-user-queue-handler)
66 ;
67 ; Tk is fussy about the order in which things happen. It likes:
68 ; - create widgets .x and .y
69 ; - make .x the -textvariable of .y
70 ; - set .x to "Hi, Mom"
71 ;
72 ; Tk does not like Step 3 going before Step 2. That is, .y will not learn about "Hi, Mom.".
73 ; Unfortunately, in a declarative paradigm one does not specify in what order different
74 ; things should happen, one just specifies the things we want to have happen. An underlying
75 ; engine then runs around taking care of making that happen, without bothering the developer
76 ; about how to do that. That includes deciding in what order to make those things happen. That is
77 ; a big win when it works. When it did not work for Tk, and I could imagine the same thing
78 ; coming up again in other situations (Tilton's Law: "The first time you run into something
79 ; is just the first time you ran into it"), I added to Cells the concept of a "client queue",
80 ; where client-code can store order-sensitive tasks. The client also can specify the handler for
81 ; that queue, here 'tk-user-queue-handler. This handler (or the default FIFO handler) gets called
82 ; at just the right time in the larger scheme of state propagation one needs for
83 ; data integrity. What is that scheme?
84 ;
85 ; Data integrity: when the overall Cells data model gets perturbed by imperative code -- typically in an
86 ; event loop -- executing a SETF of some datapoint X, we want these requirements met:
87 ;
88 ; - recompute all and (for efficiency) only state computed off X (directly or indirectly through some intermediate datapoint);
89 ;
90 ; - recomputations, when they read other datapoints, must see only values current with the new value of X;
91 ;
92 ; - similarly, client observers ("on change" callbacks) must see only values current with the new value of X; and
93 ;
94 ; - a corollary: should a client observer SETF a datapoint Y, all the above must
95 ; happen with values current with not just X, but also with the value of Y /prior/
96 ; to the change to Y.
97 ;
98 ; To achieve the above, Cells2 and now Cells3 have taken to using FIFO "unfinished business" queues
99 ; to defer things until The Right Time. Which brings us back to Tk. Inspect the source of
100 ; tk-user-queue-handler and search the Celtk source for "with-integrity (:client" to see how Celtk
101 ; manages to talk to Tk in the order Tk likes. And hack the function tk-format-now to have
102 ; Celtk dump the code it has evaluated by TCL/Tk during initialization, and notice how un-random it looks. You can
103 ; then comment out the above specification of a Tk-savvy handler to see (a) the order that would have happened
104 ; before Cells3 and (b) the demo collapse in a broken heap.
105 ;
106 ; But in short, with Cells3 we just add this requirement:
107 ;
108 ; - Deferred "client" code must see only values current with X and not any values current with some
109 ; subsequent change to Y queued by an observer
110 ;
111 (ctk:test-window 'ltktest-cells-inside))
112
113 ; That is all the imperative code there is to Celtk application development, aside from widget commands, and those
114 ; invariably (?) consist of a single setf. So where does the rest of the state change necessary to keep a GUI
115 ; interface self-consistent get taken care of?
116
117 ; Tk handles some of the driving imperative logic -- they call the company ActiveState for a reason -- and Celtk internals
118 ; handle the rest. The application works via Cells rules reacting to change by computing new state for the application model,
119 ; which operates on the outside world via observers (on-change callbacks) triggered
120 ; automatically by the Cells engine. See DEFOBSERVER.
121
122 (defun ctk::ltktest-ci ()
123 (cells-reset 'tk-user-queue-handler)
124 (ctk:test-window 'ltktest-cells-inside))
125
126 (defmodel ltktest-cells-inside (window)
127 ()
128
129 (:default-initargs
130 :id :ltk-test
131 :kids (c?
132 ; c? has quite an expansion. Functionally, one gets:
133 ; - a first-class anonymous function with the expected body, which will have access to...
134 ; - lexical variables self and .cache for the instance and prior computed value, if any
135 ; - guaranteed recomputation when the value of any other cell /used in the most recent computation/ changes
136 ;
137 ; If the abbreviation c? alarms you, look up c-formula.
138 ;
139 (the-kids
140 ;
141 ; Cells GUIs get a lot of mileage out of the family class, which is perfect
142 ; for graphical hierarchies. "the-kids" does not do much, btw.
143 ;
144 (ltk-test-menus) ;; hiding some code. see defun below for deets
145 (mk-scroller
146 ;
147 ; These "mk-" functions do nothing but expand into (make-instance 'scroller <the initarg list>)
148 ; and supply the "parent" :initarg necessary in Family trees.
149 ;
150 ; Where you see, say, mk-button-ex I am (a) poking fun at Microsoft naming of second generation
151 ; library code that did not want to break existing code and (b) adding a little more value (just
152 ; inspect the macro source to see how).
153 ;
154 :packing (c?pack-self "-side top -fill both -expand 1")
155 ;
156 ; Here is an example of how the Family class helps. The above is one of only two packing
157 ; statements needed to recreate the ltktest demo. Other packing is handled via two
158 ; slots in an inline-mixin class for various family subclasses, kids-layout and
159 ; kids-packing. The latter pulls any packing parameters and all kids into one
160 ; big pack statement kicked off by an observer on that slot. See the inline-mixin
161 ; class to see how this works.
162 ;
163 ; See the scroller class to see some automation of grids (but this was my first experience
164 ; with grids so look for that to get enhanced over time -- and later automation
165 ; of the use of PLACE.
166 ;
167 :canvas (c? (make-kid 'ltk-test-canvas))) ;; hiding some code. see defmodel thereof below
168 ;
169 ; My bad. Scroller should not assume a canvas is the scrollee. To be refined.
170 ;
171
172 (mk-row (:packing (c?pack-self "-side bottom"))
173 ;
174 ; Just expand mk-row to see what is going on. It is pretty neat in one respect: if the
175 ; first row parameter is a string, it knows to make a labelframe instead of plain frame)
176 ; The other thing it does, by forcing row parameters into a sub-list as the first argument,
177 ; is let the programmer then just list other widgets (see next) which are understood to
178 ; be kids/subwidgets contained by the frame.
179 ;
180 (mk-row (:borderwidth 2 :relief 'sunken)
181 (mk-label :text "Rotation:")
182 ;
183 ; As with Ltk Classic, the Tk widget configurations become Lisp widget initializers, so
184 ; the Tk doc documents Celtk. The advantage to the developer is that neither LTk nor
185 ; Celtk introduce a new API to be mastered, widget-wise.
186 ;
187 (mk-button-ex ("Start" (setf (moire-spin (fm^ :moire-1)) t)))
188 ;
189 ; You were warned about mk-button-ex and its ilk above. Just expand or inspect to
190 ; see what they do, which is pretty much just hide some boilerplate.
191 ;
192 ; fm^ is a wicked abbreviation for "search up the Family tree to find the widget
193 ; with this ID". ie, The Family tree effectively becomes a namespace of IDs. I have a suite of
194 ; routines that search the namespace by name so one widget can operate on or,
195 ; more commonly, ask for the value of a slot of some specific widget known to
196 ; be Out There somewhere. (Kids know their parents, so the search can reach
197 ; anywhere in the tree.)
198 ;
199 ; OK, now what is going on here? The above command starts the canvas display
200 ; spinning, by tweaking (via the (setf moire-spin) defun below) the "repeat" slot of
201 ; an ad hoc "moire" class object created to render the pretty design from
202 ; ltktest. How it accomplishes that will be explained below in the moire class
203 ; definition.
204 ;
205 (mk-button-ex ("Stop" (setf (moire-spin (fm^ :moire-1)) nil)))) ;; ditto
206
207 (mk-button-ex ("Hallo" (format T "~&Hallo")))
208 (mk-button-ex ("Welt!" (format T "~&Welt!")))
209 (mk-row (:borderwidth 2 :relief 'sunken)
210 (mk-label :text "Test:")
211 (mk-button-ex ("OK:" (setf (moire-spin (fm^ :moire-1)) 100))))
212 ;
213 ; Cells initiata will be surprised to learn the above works twice even if the button is
214 ; clicked twice in a row; Cells is about managing state change, and the second time through
215 ; there is no change. But the system still reacts! See the Timer class for the shocking
216 ; solution to this riddle.
217 ;
218 (mk-entry-numeric :id :point-ct
219 :value (c-in "42")
220 ;
221 ; to help motivate "why Cells?" a little more, we deviate from ltktest 'classic" and
222 ; start having the widgets take more interesting effect: The entry field now determines the number
223 ; of points to generate for the canvas line item, which originally was fixed at 100.
224 ; see the moire class for details.
225 ;
226 :num-parse (c? (eko ("numparse")
227 ;
228 ; (EKO is a utils-kt debug hack that prints a value along with arbitrary
229 ; other info before returning the value to the inquirer)
230 ;
231 ; Here we supplement the standard entry-numeric parse rule with
232 ; our own more stringent rule that knows about the moire task ahead.
233 ;
234 ; A vital point with this entry-numeric class (invented just now for
235 ; this demo) is that Cells does not get in the way of CLOS. We are
236 ; subclassing, using initforms, default-initargs, and, what I suspect is
237 ; a big reason Cells are such a big win: different instances of the same
238 ; class do not need to have the same rules for the same slot. Or even
239 ; have rules at all; other instances can have a constant or be setffable
240 ; from outside the model.
241 ;
242 (handler-case
243 (let ((num (parse-integer (^value))))
244 (cond
245 ((< num 2)
246 (list (format nil "Yo, Euclid, at least two, not: ~a!!" num)))
247 ((> num 200)
248 (list (format nil "Bzzt! ~a points will not look so hot." num)))
249 (t num)))
250 (parse-error (c)
251 (princ-to-string c)))))
252 :background (c? (if (user-errors (fm! :point-ct))
253 "red"
254 'SystemButtonFace))) ;; TK won't allow "" as a way of saying "default color"
255 ;
256 ; As you edit the field, if you key in an invalid (non-digit) character, the background
257 ; immediately turns red. Delete it and it reverts to the default.
258 ;
259 ; The interesting question is, how does the value slot of the Lisp instance stay
260 ; current with the text being edited in the Tk entry widget? Here we have a fundamental
261 ; difference between Ltk and Celtk. Ltk lets Tk take care of everything, including
262 ; storing the data. eg, (text my-entry) is an accessor call that asks Tk the value of
263 ; the -text configuration for the Tk instance mirrored by my-entry. There is no text
264 ; slot in the Lisp entry instance. Makes for nice, lightweight Lisp instances. But Cells works
265 ; by having datapoints watching other datapoints, so we want data in the Lisp domain
266 ; changing automatically as it changes on the TK side (such as when the user is actually
267 ; typing in the entry widget). See the entry class to see how it uses the TCL "trace write"
268 ; mechanism to keep the Lisp value slot abreast of the Tk entry text configuration
269 ; keystroke by keystroke.
270 ;
271 ; I added the :user-errors rule above to demonstrate the mechanism in action. Click
272 ; on the entry widget and type "123abc", then delete the alpha characters. The background
273 ; color (as well as the File\Save menu item state) tracks the typing.
274 ;
275
276 (mk-button-ex ("Print" (format t "~&User wants to see ~A points" (fm^v :point-ct))))
277 ;
278 ; (fm^v :point-ct) -> (value (fm^ :point-ct))
279 ;
280 ; The idea being that every Cells model object has an value slot bearing the value
281 ; of the thing being modeled. Here, the entry widget is modelling a place for users
282 ; to supply information to an application, and the value slot is a good place to
283 ; keep that information.
284 ;
285 ; Thus each class uses value to hold something different, but in all cases it is
286 ; the current value of whatever the instance of that class is understood to hold.
287 ;
288 (mk-button-ex ("Reset" (setf (fm^v :point-ct) "42")))
289 ;
290 ; Driving home this point again, in Ltk one would SETF (text my-entry) and the
291 ; SETF method would communicate with Tk to make the change to the Tk widget -text
292 ; configuration. In Celtk, the value slot of the entry gets changed (possibly
293 ; triggering other slots to update, which is why we do not just talk to Tk) and
294 ; then that value gets propagated to Tk via "set <widget path> <value>". Because
295 ; the textVariable for every entry is the entry itself, the text of the entry
296 ; then changes. If that sounds weird, what we are actually doing is tapping into
297 ; the fact that Tk to a large degree takes the same approach as Cells does with value:
298 ; in Cells, we think of model instances as wrapping some model-specific
299 ; value, which is held in the value slot of the model instance. Tk simply
300 ; allows a widget path to be a global variable. Furthermore, as the company name
301 ; ActiveState suggests, Tk also provides automatic propagation: change the
302 ; variable, and anyone with that as its textVariable also changes.
303 )))))
304
305 (defmodel ltk-test-canvas (canvas)
306 ()
307 (:default-initargs
308 :id :test-canvas
309 :background (c? (or (selection (fm! :bkg (^menus)))
310 'SystemButtonFace))
311 ;
312 ; we are taking the demo a little further to make it a little more real world than just
313 ; printing to standard output. A point to make here is the decoupling of the menu from
314 ; its application role, namely allowing the user to specify the background color of
315 ; the spinning lines. The pop-up is now a radio-group menu that does not know how the
316 ; choice it is maintaining will be used. It simply takes care of its business of allowing
317 ; the user to choose exactly one color. Changes get propagated automatically by the Cells
318 ; engine to any slot whose rule happens to read the radio-group selection slot. And the coding
319 ; is transparent: just read the value. No need to write explicit code to subscribe, notify,
320 ; or unsubscribe.
321 ;
322 :scroll-region '(0 0 500 400)
323 :gridding "-row 0 -column 0 -sticky news"
324 ;
325 ; As with packing, Celtk tries to simplify life with Tk gridding. But that is achieved partly
326 ; by automating things as with the kids-packing and kids-layout slots, and partly by staying
327 ; out of the programmer's way and letting them specify actual Tk code to be passed unfiltered
328 ; to Tk. The design choice here is to acknowledge that LTk and Celtk users really are still
329 ; doing Tk programming; only some automation (and Lispification) is provided.
330 ;
331 ; This also simplifies Celtk since it just has to pass the Tk code along with "grid <path> "
332 ; appended.
333 ;
334 :event-handler (c? (lambda (self xe)
335 (case (tk-event-type (xsv type xe))
336 (:virtualevent
337 (trc "canvas virtual" (xsv name xe)))
338 (:buttonpress
339 (TRC nil "canvas buttonpress" self (xsv x-root xe)(xsv y-root xe))
340 (pop-up (^widget-menu :bkg-pop) (xsv x-root xe) (xsv y-root xe))))))
341
342 :menus (c? (the-kids
343 ;
344 ; we could just build the menu in the rule above for event-handlers and then close over the variable
345 ; bearing the menu's Tk name in the binding callback in the call to pop-up, but I try to decompose
346 ; these things in the event that the event-handlers become dynamic over time (esp. such that the rule to generate
347 ; the binding list runs repeatedly) so we are not forever regenerating the same pop-up menu.
348 ; premature optimization? well, it also makes the code clearer, and should the list of menus become
349 ; variable over time this allows us to GC (via Tk "destroy") menus, so this is not so much about
350 ; optimization as it is about Good Things happening to well-organized code.
351 ;
352 (mk-menu
353 :id :bkg-pop
354 :kids (c? (the-kids
355 (mk-menu-radio-group
356 :id :bkg
357 :selection (c-in nil) ;; this will start us off with the Tk default
358 :kids (c? (the-kids
359 (mk-menu-entry-radiobutton :label "Crimson Tide" :value "red")
360 (mk-menu-entry-radiobutton :label "Oak Tree Ribbon" :value "yellow")
361 (mk-menu-entry-radiobutton :label "Sky" :value 'blue)
362 (mk-menu-entry-radiobutton :label "Factory" :value 'SystemButtonFace)))))))))
363
364 :kids (c? (the-kids
365 (mk-text-item
366 :coords (list 10 10)
367 :anchor "nw"
368 :text "Ltk Demonstration")
369 (make-kid 'moire :id :moire-1)))))
370 ;
371 ; we give this widget a specific ID so other rules can look it up, as
372 ; discussed above when explaining fm^.
373
374 (defmodel moire (line)
375 ((angle-1 :initarg :angle-1 :accessor angle-1 :initform (c-in 0))
376 (point-ct :initarg :point-ct :accessor point-ct
377 :initform (c? (num-value (fm^ :point-ct)))))
378 (:default-initargs
379 :timers (c? (list (make-instance 'timer
380 ;
381 ; it occurred to me that it might be useful to build a timer utility
382 ; around the TCL after command. See the class definition of timer
383 ; for the fireworks (in terms of Cells) that resulted
384 ;
385 :repeat (c-in t)
386 :delay 1 ;; milliseconds since this gets passed unvarnished to TK after
387 :action (lambda (timer)
388 (declare (ignorable timer))
389 (trc nil "timer fires!!" timer)
390 (incf (^angle-1) 0.1)))))
391 :coords (c? (let ((angle-2 (* 0.3 (^angle-1)))
392 (wx (sin (* 0.1 (^angle-1)))))
393 (loop for i below (^point-ct)
394 for w = (+ (^angle-1) (* i 2.8001))
395 for x = (+ (* 50 (sin angle-2)) 250 (* 150 (sin w) (1+ wx)))
396 for y = (+ (* 50 (cos angle-2)) 200 (* 150 (cos w)))
397 nconcing (list x y))))))
398
399 (defun (setf moire-spin) (repeat self)
400 (setf (repeat (car (timers self))) repeat)) ;; just hiding the implementation
401
402 (defun ltk-test-menus ()
403 ;
404 ; The only difference is that the menu structure as seen by the user
405 ; is apparent here, which might help some when reorganizing menus.
406 ;
407 ; Well, another thing which happens not to be visible here... hang on.
408 ; OK, I just made the Save menu item contingent upon there being no
409 ; user-errors. As you add/remove all digits (considered invalid for
410 ; demonstration purposes) the menu item becomes available/unavailable
411 ; appropriately.
412 ;
413 ; This is the kind of thing that Cells is good for.
414 ;
415 (mk-menubar
416 :kids (c? (the-kids
417 (mk-menu-entry-cascade-ex (:label "File")
418 (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed"))
419 (mk-menu-entry-command-ex (:state (c? (if (user-errors (fm^ :point-ct))
420 :disabled :normal)))
421 "Save" (format t "~&Save pressed"))
422 (mk-menu-entry-separator)
423 (mk-menu-entry-cascade-ex (:id :export :label "Export...")
424 (mk-menu-entry-command-ex () "jpeg" (format t "~&Jpeg pressed"))
425 (mk-menu-entry-command-ex () "png" (format t "~&Png pressed")))
426 (mk-menu-entry-separator)
427 (mk-menu-entry-command :label "Quit"
428 :accelerator "Alt-q"
429 ;
430 ; check out the observer on the accelerator slot of the class menu-entry-usable
431 ; to see how Celtk fills in a gap in Tk: accelerators should work just by
432 ; declaring them to the menu widget, it seems to me. In Celtk, they do.
433 ;
434 :underline 1
435 :command "destroy .; break"))))))
436
437
438 (defmodel entry-numeric (entry)
439 ((num-parse :initarg :num-parse :accessor num-parse
440 :initform (c? (eko ("numparse")
441 (handler-case
442 (parse-integer (^value))
443 (parse-error (c)
444 (princ-to-string c))))))
445 (num-value :initarg :num-value :accessor num-value
446 :initform (c? (if (numberp (^num-parse))
447 (^num-parse)
448 (or .cache 42)))))
449 (:default-initargs
450 :value "42"
451 :user-errors (c? (unless (numberp (^num-parse))
452 (^num-parse)))))
453
454
455 (defun mk-entry-numeric (&rest iargs)
456 (apply 'make-instance 'entry-numeric :fm-parent *parent* iargs))
457

  ViewVC Help
Powered by ViewVC 1.1.5