[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Sat Mar 25 11:32:44 UTC 2006
Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv25467
Modified Files:
CELTK.lpr Celtk.lisp demos.lisp ltktest-cells-inside.lisp
tk-format.lisp
Log Message:
Punch up ltktest-cells-inside doc and functionality just a little
--- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/24 03:46:25 1.3
+++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/25 11:32:44 1.4
@@ -5,8 +5,7 @@
(defpackage :CELTK)
(define-project :name :celtk
- :modules (list (make-instance 'module :name
- "C:\\0devtools\\ltk\\ltk.lisp")
+ :modules (list (make-instance 'module :name "ltk-kt.lisp")
(make-instance 'module :name "Celtk.lisp")
(make-instance 'module :name "tk-format.lisp")
(make-instance 'module :name "menu.lisp")
--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/24 12:09:44 1.8
+++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/25 11:32:44 1.9
@@ -250,7 +250,7 @@
(defobserver coords ()
(when (and (id-no self) new-value)
- (tk-format `(:coords ,self)
+ (tk-format `(:configure ,self)
"~a coords ~a ~{ ~a~}" (path .parent) (id-no self) new-value)))
(defmethod not-to-be :after ((self item))
--- /project/cells/cvsroot/Celtk/demos.lisp 2006/03/24 03:46:25 1.4
+++ /project/cells/cvsroot/Celtk/demos.lisp 2006/03/25 11:32:44 1.5
@@ -24,7 +24,9 @@
(in-package :celtk-user)
(defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package
- (tk-test-class 'ltktest-cells-inside))
+ (tk-test-class 'ltktest-cells-inside)
+ ;;(tk-test-class 'lotsa-widgets)
+ )
(defun tk-test-class (root-class)
(cells-reset 'tk-user-queue-handler)
@@ -197,7 +199,7 @@
(mk-popup-menubutton
:id :font-face
:initial-value (c? (second (^entry-values)))
- :entry-values (c? (tk-eval-list self "font families")))
+ :entry-values (c? (eko ("ff") (tk-eval-list self "font families"))))
(mk-scale :id :font-size
:md-value (c-in 14)
@@ -301,7 +303,7 @@
:from 7 :to 24
:orient 'horizontal)
(mk-label :id :txt
- :text "Four score and seven years ago today"
+ :text "Four score seven years ago today"
:wraplength 600
:font (c? (list ;; format nil "{{~{~a~^ ~}} ~a}" ;; eg, {{wp greek century} 24}
(md-value (fm^ :font-face))
--- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/24 12:09:44 1.8
+++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/25 11:32:44 1.9
@@ -77,11 +77,11 @@
; (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 datapoint) must be recomputed;
+ ; - recompute all and only state computed off X (directly or indirectly through some intermediate datapoint);
; - 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
+ ; - a corollary: 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.
;
@@ -102,15 +102,15 @@
(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)
+ :initform (c? (bwhen (bad-chars (loop for c across (fm!v :coord-ct)
+ unless (digit-char-p c)
collect c))
- (format nil "Please! No digits! I see ~a!!" bad-chars)))
+ (format nil "Please! Only 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.
+ ; check that out for details.
;
- :documentation "Demonstrate live tracking of entry edit"))
+ :documentation "Demonstrate live tracking key by key of entry widget editing"))
(:default-initargs
:id :ltk-test
@@ -119,7 +119,7 @@
; - a first-class anonymous function with the expected body, which will have access to
; - variables self and .cache (symbol macro, last I looked) for the instance and prior
; computed value, if any
- ; - guaranteed recomputation when the value of any other cell used in the computation changes
+ ; - guaranteed recomputation when the value of any other cell /used in the most recent computation/ changes
;
; If the abbreviation bothers you, look up c-formula.
;
@@ -161,17 +161,22 @@
; 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 (packed or gridded) within the frame.
+ ; 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.
+ ; 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 (hey, this is open source, look it up or
- ; macroexpand it). The long story is that the Family tree becomes effectively
- ; a namespace, where the ID slot is the name of a widget. I have a suite of
+ ; 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
@@ -191,53 +196,73 @@
(mk-button-ex ("Hallo" (format T "~&Hallo")))
(mk-button-ex ("Welt!" (format T "~&Welt")))
- (mk-row (:borderwidth 2
- :relief 'sunken)
+ (mk-row (:borderwidth 2 :relief 'sunken)
(mk-label :text "Test:")
(mk-button-ex ("OK:" (setf (moire-spin (fm^ :moire-1)) 20))))
- (mk-entry :id :entry
+ ;
+ ; 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. See the Timer class for the solution to this riddle.
+ ;
+ (mk-entry :id :coord-ct
+ ;
+ ; to help motivate "why Cells?" a little more, we start having the widgets take more
+ ; interesting effect on each other. The boring entry field now determines the number
+ ; of coordinates to generate for the canvas line item, which originally was fixed at 100.
+ ; see the moire class for details.
+ ;
+ :md-value (c-in "40")
:background (c? (if (entry-warning .tkw)
;
; ok, this is silly, the validation is entry-specific
- ; and should be a rule applied to this entry widget, but I
- ; will leave it silly to make clear that cells of an instance
- ; can depend on cells of other instances
+ ; and should be a rule specified to this entry widget. Instead,
+ ; while casually hacking away I stuck it on the window (.tkw, explained
+ ; in the next paragraph. The Right Way (and coming soon) is an "errors"
+ ; slot on every tk-object, but I
+ ; will leave it silly to make clear that cells of one instance
+ ; can depend on cells of other instances. More discussion a few lines down.
;
- ; so what is .tkw? A symbol macro for (nearest self window).
+ ; so what is .tkw? A symbol macro for "(nearest self window)".
; what is nearest? It searches up the Family tree from
; self inclusive searching for something (typep 'window)
;
"red"
- 'SystemButtonFace)))
- (mk-button-ex ("get!" (format t "~&content of entry: ~A" (fm^v :entry))))
+ 'SystemButtonFace))) ;; TK won't allow "" as a way of saying "default color"
;
- ; fm^v -> (md-value (fm^ ....
+ ; As you type in 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 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.
- ;
; 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
+ ; 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 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.
+ ; I added the entry-warning slot 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. (And an observer
+ ; chats away on standard output.)
+ ;
+
+ (mk-button-ex ("get!" (format t "~&content of entry: ~A" (fm^v :coord-ct))))
;
- (mk-button-ex ("set!" (setf (fm^v :entry) "test of set")))
+ ; (fm^v :coord-ct) -> (md-value (fm^ :coord-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 ("set!" (setf (fm^v :coord-ct) "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
@@ -262,7 +287,7 @@
(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)))))
+ (format t "~&That looks better: ~a" (fm!v :coord-ct)))))
(defmodel ltk-test-canvas (canvas)
()
@@ -330,7 +355,13 @@
; discussed above when explaining fm^.
(defmodel moire (line)
- ((angle-1 :initarg :angle-1 :accessor angle-1 :initform (c-in 0)))
+ ((angle-1 :initarg :angle-1 :accessor angle-1 :initform (c-in 0))
+ (coord-ct :initarg :coord-ct :accessor coord-ct
+ :initform (c? (or (unless (entry-warning .tkw)
+ (let ((ct (read-from-string (fm^v :coord-ct) nil)))
+ (when (and (numberp ct) (> ct 1))
+ (max ct 2))))
+ .cache)))) ;; ie, prior value
(:default-initargs
:timers (c? (list (make-instance 'timer
;
@@ -344,12 +375,12 @@
(declare (ignore 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 100
- 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))))))
+ (wx (sin (* 0.1 (^angle-1)))))
+ (loop for i below (^coord-ct)
+ 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)) ;; just hiding the implementation
--- /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/24 12:09:44 1.5
+++ /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/25 11:32:44 1.6
@@ -56,12 +56,12 @@
(trc nil "!!! --- tk-user-queue-handler dispatching" defer-info)
(funcall task)))
-#+debug
+#+nahh
(defun tk-format-now (fmt$ &rest fmt-args &aux (tk$ (apply 'format nil fmt$ fmt-args)))
;
; --- pure debug stuff ---
;
- (let ((yes '( "bind" "invoke")) ;; '("scroll" "pkg-sym"))
+ (let ((yes '( "coords" )) ;; '("scroll" "pkg-sym"))
(no '()))
(declare (ignorable yes no))
(bwhen (st (search "\"Alt Q\"" tk$))
@@ -78,6 +78,7 @@
(format (wish-stream *wish*) "~A~%" tk$)
(force-output (wish-stream *wish*)))
+
(defun tk-format-now (fmt$ &rest fmt-args &aux (tk$ (apply 'format nil fmt$ fmt-args)))
;;(format t "~&tk> ~A~%" tk$)
(format (wish-stream *wish*) "~A~%" tk$)
More information about the Cells-cvs
mailing list