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 + ,@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)