[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Tue Mar 28 04:02:08 UTC 2006
Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv2995
Modified Files:
Celtk.lisp canvas.lisp composites.lisp demos.lisp
ltktest-cells-inside.lisp menu.lisp textual.lisp widgets.lisp
Log Message:
Wow, I changed all these? Only news is light editing of ltk-cells-inside.
--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/26 14:07:15 1.11
+++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/28 04:02:08 1.12
@@ -23,32 +23,33 @@
(defpackage :celtk
(:nicknames "CTK")
(:use :common-lisp :utils-kt :cells)
-
+
(:import-from #:ltk
#:wish-stream #:*wish* #:widget-path
#:read-data #:event-root-x #:event-root-y
#:send-wish #:tkescape #:after #:after-cancel #:bind
#:with-ltk #:do-execute #:add-callback)
-
+
(:export
- #:pop-up #:event-root-x #:event-root-y
+ #:pop-up #:event-root-x #:event-root-y
#:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget
- #:mk-panedwindow
+ #:mk-panedwindow
#:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label #:selection #:selector
- #:mk-checkbutton #:mk-button #:mk-button-ex #:entry #:mk-entry #:text
- #:frame-stack #:mk-frame-stack #:path #:^path
- #:mk-menu-entry-radiobutton #:mk-menu-entry-checkbutton
- #:mk-menu-radio-group #:mk-menu-entry-separator
- #:mk-menu-entry-command #:tk-callback #:menu #:mk-menu #:^menus #:mk-menu-entry-cascade #:mk-menubar
- #:^entry-values #:tk-eval-list #:mk-scale #:mk-popup-menubutton
- #:polygon #:mk-polygon #:oval #:mk-oval #:line #:mk-line #:arc #:mk-arc #:text-item #:mk-text-item
- #:rectangle #:mk-rectangle #:bitmap #:mk-bitmap #:canvas #:mk-canvas #:mk-frame-row
- #:mk-scrolled-list #:listbox-item #:mk-spinbox
- #:mk-scroller #:mk-menu-entry-cascade-ex
- #:with-ltk #:tk-format #:send-wish #:value #:.tkw
- #:tk-user-queue-handler #:user-errors #:^user-errors
+ #:mk-checkbutton #:mk-button #:mk-button-ex #:entry #:mk-entry #:text
+ #:frame-stack #:mk-frame-stack #:path #:^path
+ #:mk-menu-entry-radiobutton #:mk-menu-entry-checkbutton
+ #:mk-menu-radio-group #:mk-menu-entry-separator
+ #:mk-menu-entry-command #:mk-menu-entry-command-ex #:tk-callback
+ #:menu #:mk-menu #:^menus #:mk-menu-entry-cascade #:mk-menubar
+ #:^entry-values #:tk-eval-list #:mk-scale #:mk-popup-menubutton
+ #:polygon #:mk-polygon #:oval #:mk-oval #:line #:mk-line #:arc #:mk-arc #:text-item #:mk-text-item
+ #:rectangle #:mk-rectangle #:bitmap #:mk-bitmap #:canvas #:mk-canvas #:mk-frame-row
+ #:mk-scrolled-list #:listbox-item #:mk-spinbox
+ #:mk-scroller #:mk-menu-entry-cascade-ex
+ #:with-ltk #:tk-format #:send-wish #:value #:.tkw
+ #:tk-user-queue-handler #:user-errors #:^user-errors
#:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps
- #:^widget-menu #:widget-menu))
+ #:^widget-menu #:widget-menu #:tk-format-now))
(defpackage :celtk-user
(:use :common-lisp :utils-kt :cells :celtk))
@@ -365,8 +366,7 @@
(tk-format :grouped "senddatastring [set ~a]" var)
(read-data))
-(defun tk-eval-list (self form$)
- (declare (ignore self))
+(defun tk-eval-list (form$)
(tk-format :grouped "senddatastrings [~a]" form$)
(read-data))
--- /project/cells/cvsroot/Celtk/canvas.lisp 2006/03/24 03:46:25 1.2
+++ /project/cells/cvsroot/Celtk/canvas.lisp 2006/03/28 04:02:08 1.3
@@ -33,7 +33,9 @@
-closeenough -confine -height (scroll-region -scrollregion) -width
-xscrollincrement -yscrollincrement)
(:default-initargs
- :id (gentemp "CV")))
+ :xscrollcommand (c-in nil)
+ :yscrollcommand (c-in nil)
+ :id (gentemp "CV")))
(deftk arc (item)
()
--- /project/cells/cvsroot/Celtk/composites.lisp 2006/03/24 03:46:25 1.3
+++ /project/cells/cvsroot/Celtk/composites.lisp 2006/03/28 04:02:08 1.4
@@ -75,7 +75,7 @@
(defmodel window (composite-widget)
((wish :initarg :wish :accessor wish
:initform (wish-stream *wish*)
- #+(or) (c? (do-execute "wish84 -name testwindow"
+ #+(or) (c? (do-execute "wish85 -name testwindow"
nil #+not (list (format nil "-name ~s" (title$ self))))))
(ewish :initarg :ewish :accessor ewish :initform nil :cell nil) ;; vestigial?
(title$ :initarg :title$ :accessor title$
--- /project/cells/cvsroot/Celtk/demos.lisp 2006/03/25 11:32:44 1.5
+++ /project/cells/cvsroot/Celtk/demos.lisp 2006/03/28 04:02:08 1.6
@@ -32,6 +32,7 @@
(cells-reset 'tk-user-queue-handler)
(with-ltk (:debug 0)
(send-wish "proc trc2 {cb n1 n2 op} {puts \"(:callback \\\"$cb\\\" :name1 $n1 :name2 \\\"$n2\\\" :op $op)\"}")
+ #+notyet (send-wish "package require tile")
(setf ltk:*debug-tk* nil)
(with-integrity ()
(make-instance root-class))
@@ -199,7 +200,7 @@
(mk-popup-menubutton
:id :font-face
:initial-value (c? (second (^entry-values)))
- :entry-values (c? (eko ("ff") (tk-eval-list self "font families"))))
+ :entry-values (c? (eko (nil "ff") (tk-eval-list "font families"))))
(mk-scale :id :font-size
:md-value (c-in 14)
@@ -289,7 +290,7 @@
(defmodel font-view (frame-stack)
()
(:default-initargs
- :md-value (c? (tk-eval-list self "font families"))
+ :md-value (c? (tk-eval-list "font families"))
:pady 2 :padx 4
:packing-side 'left
:layout-anchor 'nw
--- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/26 14:07:15 1.11
+++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/28 04:02:08 1.12
@@ -40,11 +40,10 @@
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 lay them out carefully one by one to get exactly what they want without thinking
+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. The trade-off becomes a big win for the declarative model as the
-interface gets either bigger or more dynamic, such as widgets that come and go as the
-user specifies different things in other widgets.
+do less work as the responsibility for getting things to work falls on the engine behind
+the declarative interface.
Second topic:
@@ -74,25 +73,27 @@
; 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. Including 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 see the same thing
- ; coming up again in other situations, I added to Cells the concept of a "client queue".
+ ; 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 will run into it"), I added to Cells the concept of a "client queue".
; Here client-code can store order-sensitive tasks. The client also can specify the handler for
- ; that queue. 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?
+ ; 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?
;
; 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 satisfied:
+ ; event loop -- executing a SETF of some datapoint X, we want these requirements met:
;
; - 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;
+ ; - 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
+ ; - 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 not just with X, but also with the value of Y /prior/
- ; to the intended change to Y.
+ ; 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
@@ -268,8 +269,7 @@
;
; 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. (And an observer
- ; chats away on standard output.)
+ ; 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))))
@@ -282,19 +282,19 @@
; 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 current value of whatever the instance of that class is understood to hold.
;
(mk-button-ex ("Reset" (setf (fm^v :point-ct) "42")))
;
- ; In Ltk one would SETF (text my-entry) and the
+ ; 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
- ; 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
+ ; 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
@@ -314,8 +314,9 @@
; 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 that
- ; is all they have to do, read the value. No need to code "subscribe" or "notify" code.
+ ; 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"
@@ -328,25 +329,23 @@
;
; This also simplifies Celtk since it just has to pass the Tk code along with "grid <path> "
; appended.
- ;
- :xscrollcommand (c-in nil) ;; see canvas class for the Tk limitation behind this nonsense
- :yscrollcommand (c-in nil) ;; in brief, Tk lacks the concept of "late binding" on widget names
-
- :bindings (c? (list (list "<1>" (lambda (event)
- ;
- ; 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) ;; (^menus) -> (menus self)
- (event-root-x event)
- (event-root-y event))))))
+ ;
+ :bindings (c? (list
+ (list "<1>" (lambda (event)
+ ;
+ ; 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) ;; (^menus) -> (menus self)
+ (event-root-x event)
+ (event-root-y event))))))
:menus (c? (the-kids
;
@@ -356,32 +355,19 @@
; the binding list will run repeatedly) 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 allows us to GC (via Tk "destroy") menus, so this is not so much about
- ; optimization as it is about the Good Things that happen to well-organized code.
+ ; 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)
+ :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
- :id :options
- :kids (c? (the-kids
- (mapcar (lambda (spec)
- (destructuring-bind (lbl . out$) spec
- (mk-menu-entry-command
- :label lbl
- :command (c? (tk-callback .tkw (gentemp "MNU")
- (lambda ()
- (format t "~&~a" out$)))))))
- (list (cons "Option 1" "Popup 1")
- (cons "Option 2" "Popup 2")
- (cons "Option 3" "Popup 3"))))))))
+ (mk-menu-entry-radiobutton :label "Sky" :value 'blue)
+ (mk-menu-entry-radiobutton :label "Factory" :value 'SystemButtonFace)))))))))
:kids (c? (the-kids
(mk-text-item
@@ -437,25 +423,14 @@
(mk-menubar
:kids (c? (the-kids
(mk-menu-entry-cascade-ex (:label "File")
- (mk-menu-entry-command :label "Load"
- :command (c? (tk-callback .tkw 'load
- (lambda () (format t "~&Load pressed")))))
-
- (mk-menu-entry-command :label "Save"
- :state (c? (if (user-errors (fm^ :point-ct))
- :disabled :normal))
- :command (c? (tk-callback .tkw 'save
- (lambda () (format t "~&Save pressed")))))
+ (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed"))
+ (mk-menu-entry-command-ex (:state (c? (if (user-errors (fm^ :point-ct))
+ :disabled :normal)))
+ "Save" (format t "~&Save pressed"))
(mk-menu-entry-separator)
(mk-menu-entry-cascade-ex (:id :export :label "Export...")
- (mk-menu-entry-command
- :label "jpeg"
- :command (c? (tk-callback .tkw 'jpeg
- (lambda () (format t "~&Jpeg pressed")))))
- (mk-menu-entry-command
- :label "png"
- :command (c? (tk-callback .tkw 'png
- (lambda () (format t "~&Png pressed"))))))
+ (mk-menu-entry-command-ex () "jpeg" (format t "~&Jpeg pressed"))
+ (mk-menu-entry-command-ex () "png" (format t "~&Png pressed")))
(mk-menu-entry-separator)
(mk-menu-entry-command :label "Quit"
:accelerator "Alt-q"
--- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/24 03:46:25 1.5
+++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/28 04:02:08 1.6
@@ -171,6 +171,14 @@
()
(:tk-spec command -command))
+(defmacro mk-menu-entry-command-ex ((&rest menu-command-initargs) lbl callback-body)
+ `(mk-menu-entry-command
+ , at menu-command-initargs
+ :label ,lbl
+ :command (c? (tk-callback .tkw (gentemp "MNU")
+ (lambda ()
+ ,callback-body)))))
+
(deftk menu-entry-button (menu-entry-command)
()
(:tk-spec command
--- /project/cells/cvsroot/Celtk/textual.lisp 2006/03/24 03:46:25 1.4
+++ /project/cells/cvsroot/Celtk/textual.lisp 2006/03/28 04:02:08 1.5
@@ -69,6 +69,7 @@
-validate -validatecommand -width )
(:default-initargs
:id (gentemp "ENT")
+ :xscrollcommand (c-in nil)
:textvariable (c? (^path))
:md-value (c-in "")))
@@ -110,6 +111,8 @@
(:default-initargs
:id (gentemp "TXT")
:md-value (c-in "<your text here>")
+ :xscrollcommand (c-in nil)
+ :yscrollcommand (c-in nil)
:modified (c-in nil)
:bindings (c? (list (list "<<Modified>>"
(format nil "{callback ~~a}" (^path))
--- /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/24 03:46:25 1.3
+++ /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/28 04:02:08 1.4
@@ -120,6 +120,8 @@
:id (gentemp "SCL")
:md-value (c-in nil)
:tk-variable nil ;;(c? (^path))
+ :xscrollcommand (c-in nil)
+ :yscrollcommand (c-in nil)
:command (c? (tk-callbackval self 'scale-set
(lambda (&rest args)
(declare (ignore id))
@@ -143,6 +145,8 @@
-takefocus -width -xscrollcommand -yscrollcommand)
(:default-initargs
:id (gentemp "LBX")
+ :xscrollcommand (c-in nil)
+ :yscrollcommand (c-in nil)
:bindings (c? (when (selector self) ;; if not? Figure out how listbox tracks own selection
(list (list "<<ListboxSelect>>"
(format nil "{callbackval ~~a [~a curselection]}" (^path))
@@ -186,6 +190,7 @@
:md-value (c-in nil)
:id (gentemp "SPN")
:textVariable (c? (^path))
+ :xscrollcommand (c-in nil)
:command (c? (tk-callbackstring-x self 'vmirror "%s"
;;;(tk-callback self 'vcmd
(lambda (text)
More information about the Cells-cvs
mailing list