March 2006 - cells-cvs@common-lisp.net - mailman3.common-lisp.net

[cells-cvs] CVS Celtk
by ktilton 28 Mar '06

28 Mar '06

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)

1 0

[cells-cvs] CVS Celtk
by ktilton 26 Mar '06

26 Mar '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv14804 Modified Files: Celtk.lisp ltktest-cells-inside.lisp Log Message: popup menu now sets canvas background color --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/26 03:40:59 1.10 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/26 14:07:15 1.11 @@ -39,7 +39,7 @@ #: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 #:mk-menu #:^menus #:mk-menu-entry-cascade #:mk-menubar + #: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 @@ -47,7 +47,8 @@ #: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)) + #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps + #:^widget-menu #:widget-menu)) (defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) @@ -149,13 +150,21 @@ (gridding :reader gridding :initarg :gridding :initform nil) (enabled :reader enabled :initarg :enabled :initform t) (bindings :reader bindings :initarg :bindings :initform nil) - (menus :reader menus :initarg :menus :initform nil) + (menus :reader menus :initarg :menus :initform nil + :documentation "An assoc of an arbitrary key and the associated CLOS menu instances (not their tk ids)") (image-files :reader image-files :initarg :image-files :initform nil) (selector :reader selector :initarg :selector :initform (c? (upper self selector)))) (:default-initargs :id (gentemp "W"))) +(defun widget-menu (self key) + (or (find key (^menus) :key 'md-name) + (break "The only menus I see are~{ ~a,~} not requested ~a" (mapcar 'md-name (^menus)) key))) + +(defmacro ^widget-menu (key) + `(widget-menu self ,key)) + (defmethod make-tk-instance ((self widget)) (setf (gethash (^path) (dictionary .tkw)) self) (when (tk-class self) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/26 03:40:59 1.10 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/26 14:07:15 1.11 @@ -38,7 +38,13 @@ 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. +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 +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. Second topic: @@ -103,9 +109,13 @@ ; (tk-test-class 'ltktest-cells-inside)) -; That is all the imperative code there is to Celtk application development, aside from widget commands. Tk handles some -; of the driving imperative logic, and Celtk internals handle the rest. The application works via rules reacting to change, -; computing new state for the application model, which operates on the outside world via observers (on-change callbacks) triggered +; 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) @@ -295,6 +305,18 @@ () (: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 that + ; is all they have to do, read the value. No need to code "subscribe" or "notify" code. + ; :scroll-region '(0 0 500 400) :gridding "-row 0 -column 0 -sticky news" ; @@ -309,7 +331,7 @@ ; :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 @@ -322,21 +344,33 @@ ; an observer on the bindings slot passes the needed bindings to Tk ; via the client queue. ; - (pop-up (car (^menus)) ;; (^menus) -> (menus self) + (pop-up (^widget-menu :bkg-pop) ;; (^menus) -> (menus self) (event-root-x event) (event-root-y event)))))) + :menus (c? (the-kids ; - ; here is a limitation with the declarative paradigm: pop-up menus are free to float about - ; unpacked in any parent. One just needs to remember the name of the menu widget to - ; pass it to the pop-up function. So imperative code like ltktest "classic" can just make the menus - ; saving their name in a closed-over local variable and then refer to them in a callback to pop them up. - ; - ; in the declarative paradigm we need a slot (defined for any widget or item class) in which - ; to build and store such menus. As with bindings, the nice thing again is that we find everything relative - ; to this widget specified in one place. + ; 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 (meaning the rule to generate + ; 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. ; + (mk-menu + :id :bkg-pop + :kids (c? (the-kids + (mk-menu-radio-group + :id :bkg + :selection (c-in nil) + :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

1 0

[cells-cvs] CVS cells
by ktilton 26 Mar '06

26 Mar '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv14755 Modified Files: fm-utilities.lisp Log Message: fm-find-one now will behave well with a list as the toplevel search object --- /project/cells/cvsroot/cells/fm-utilities.lisp 2006/03/16 05:28:28 1.4 +++ /project/cells/cvsroot/cells/fm-utilities.lisp 2006/03/26 14:05:49 1.5 @@ -127,15 +127,17 @@ (without-c-dependency (when family (labels ((tv-family (fm) - (when (and (typep fm 'model-object) - (not (eql fm skip-tree))) - (let ((outcome (and (not (eql skip-node fm)) ;; skipnode new 990310 kt - (funcall applied-fn fm)))) - (unless (and outcome opaque) - (dolist (kid (kids fm)) - (tv-family kid)) - ;(tv-family (mdValue fm)) - ))))) + (etypecase fm + (cons (loop for md in fm do (tv-family md))) + (model-object + (unless (eql fm skip-tree) + (let ((outcome (and (not (eql skip-node fm)) ;; skipnode new 990310 kt + (funcall applied-fn fm)))) + (unless (and outcome opaque) + (dolist (kid (kids fm)) + (tv-family kid)) + ;(tv-family (mdValue fm)) + ))))))) (tv-family family) (when global-search (fm-traverse (fm-parent family) applied-fn

1 0

[cells-cvs] CVS Celtk
by ktilton 26 Mar '06

26 Mar '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv6103 Modified Files: Celtk.lisp ltktest-cells-inside.lisp Log Message: Stop me before I refine the demo again! --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/25 11:32:44 1.9 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/26 03:40:59 1.10 @@ -35,18 +35,19 @@ #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:mk-panedwindow #:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label #:selection #:selector - #:mk-checkbutton #:mk-button #:mk-button-ex #:mk-entry #:text + #: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 #: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-tem #:mk-text-item + #: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 #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps)) + #:tk-user-queue-handler #:user-errors #:^user-errors + #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps)) (defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) @@ -57,7 +58,8 @@ (defmodel tk-object (model) ((.md-name :cell nil :initform (gentemp "TK") :initarg :id) (tk-class :cell nil :initform nil :initarg :tk-class :reader tk-class) - (timers :initarg :timers :accessor timers :initform nil))) + (timers :initarg :timers :accessor timers :initform nil) + (user-errors :initarg :user-errors :accessor user-errors :initform nil))) (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self)) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/25 11:32:44 1.9 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/26 03:40:59 1.10 @@ -47,7 +47,7 @@ Those questions are different because not everything different about Celtk depends on Cells. -The pattern will be to have explanatory comments appear after the explained code. +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 @@ -66,21 +66,24 @@ ; ; 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. That is - ; a big win when it works. But when it did not work for Tk I added to Cells the concept - ; of a "client queue" where client-code could store - ; order-sensitive tasks, also allowing the client to specify the handler for - ; that queue. This 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 data model gets perturbed by imperative code - ; (such as code processing an event loop) executing a SETF of some datapoint X , we want - ; these requirements satisfied: + ; 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". + ; 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? + ; + ; 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: ; ; - 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; + ; + ; - recomputations must see only datapoint 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 + ; ; - 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. @@ -88,9 +91,14 @@ ; 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. But in short, we just add this requirement: + ; 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 heap (or not work in vital ways). + ; + ; But in short, with Cells3 we just add this requirement: ; - ; - Client code must see only values current with X and not any values current with some + ; - 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 ; (tk-test-class 'ltktest-cells-inside)) @@ -101,27 +109,17 @@ ; automatically by the Cells engine. See DEFOBSERVER. (defmodel ltktest-cells-inside (window) - ((entry-warning :reader entry-warning - :initform (c? (bwhen (bad-chars (loop for c across (fm!v :coord-ct) - unless (digit-char-p c) - collect c)) - (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 that out for details. - ; - :documentation "Demonstrate live tracking key by key of entry widget editing")) + () (:default-initargs :id :ltk-test :kids (c? - ; c? has one hell of an expansion. In effect one gets: - ; - 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 + ; 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 bothers you, look up c-formula. + ; If the abbreviation c? alarms you, look up c-formula. ; (the-kids ; @@ -131,7 +129,9 @@ (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>). + ; 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). @@ -193,7 +193,6 @@ ; ditto ; - (mk-button-ex ("Hallo" (format T "~&Hallo"))) (mk-button-ex ("Welt!" (format T "~&Welt"))) (mk-row (:borderwidth 2 :relief 'sunken) @@ -202,31 +201,44 @@ ; ; 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. + ; there is no change. See the Timer class for the shocking solution to this riddle. ; - (mk-entry :id :coord-ct + (mk-entry-numeric :id :point-ct + :md-value (c-in "42") ; - ; 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. + ; 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. ; - :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 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)". - ; what is nearest? It searches up the Family tree from - ; self inclusive searching for something (typep 'window) - ; - "red" + :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 type in the field, if you key in an invalid (non-digit) character, the background @@ -244,15 +256,15 @@ ; mechanism to keep the Lisp md-value slot abreast of the Tk entry text configuration ; keystroke by keystroke. ; - ; I added the entry-warning slot above to demonstrate the mechanism in action. Click + ; 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.) ; - (mk-button-ex ("get!" (format t "~&content of entry: ~A" (fm^v :coord-ct)))) + (mk-button-ex ("Print" (format t "~&User wants to see ~A points" (fm^v :point-ct)))) ; - ; (fm^v :coord-ct) -> (md-value (fm^ :coord-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 @@ -262,7 +274,7 @@ ; 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"))) + (mk-button-ex ("Reset" (setf (fm^v :point-ct) "42"))) ; ; 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 @@ -278,16 +290,6 @@ ; ActiveState suggests, Tk also provides automatic propagation: change the ; variable, and anyone with that as its textVariable also changes. ))))) - -(defobserver entry-warning () - ; - ; This demonstrates ones ability to track the text in a Tk entry while it is being - ; edited. As you type you should see the changing values in standard output - ; - (if new-value - (format t "~&User, we have a problem: ~a" new-value) - (when old-value - (format t "~&That looks better: ~a" (fm!v :coord-ct))))) (defmodel ltk-test-canvas (canvas) () @@ -306,43 +308,46 @@ ; appended. ; :xscrollcommand (c-in nil) ;; see canvas class for the Tk limitation behind this nonsense - :yscrollcommand (c-in nil) ;; in brief, Tk needs the concept of "late binding" on widget names + :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 (car (^menus)) ;; (^menus) -> (menus self) (event-root-x event) (event-root-y event)))))) - ; - ; an observer on the bindings slot (a) registers a callback and (b) passes along - ; to Tk an appropriate BIND command - ; - :menus - ; - ; here is a limitation with the declarative paradigm. pop-up menus are free to float about - ; unpacked in any parent. One just needs to remember the name of the menu widget to - ; pass it to the pop-up function. So imperative code like ltktest "classic" can just make the menus - ; saving their name in a closed-over local variable and then refer to them in a callback to pop them up. - ; - ; in the declarative paradigm we need a slot (defined for any widget or item class) in which - ; to build and store such menus: - ; - (c? (the-kids - (mk-menu - :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")))))))) + :menus (c? (the-kids + ; + ; here is a limitation with the declarative paradigm: pop-up menus are free to float about + ; unpacked in any parent. One just needs to remember the name of the menu widget to + ; pass it to the pop-up function. So imperative code like ltktest "classic" can just make the menus + ; saving their name in a closed-over local variable and then refer to them in a callback to pop them up. + ; + ; in the declarative paradigm we need a slot (defined for any widget or item class) in which + ; to build and store such menus. As with bindings, the nice thing again is that we find everything relative + ; to this widget specified in one place. + ; + (mk-menu + :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")))))))) :kids (c? (the-kids (mk-text-item @@ -351,17 +356,13 @@ :text "Ltk Demonstration") (make-kid 'moire :id :moire-1))))) ; - ; we give /this/ widget a specific ID so other rules can look it up, as + ; 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)) - (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 + (point-ct :initarg :point-ct :accessor point-ct + :initform (c? (num-value (fm^ :point-ct))))) (:default-initargs :timers (c? (list (make-instance 'timer ; @@ -376,12 +377,13 @@ (incf (^angle-1) 0.1))))) :coords (c? (let ((angle-2 (* 0.3 (^angle-1))) (wx (sin (* 0.1 (^angle-1))))) - (loop for i below (^coord-ct) + (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))) 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 @@ -392,7 +394,7 @@ ; ; Well, another thing which happens not to be visible here... hang on. ; OK, I just made the Save menu item contingent upon there being no - ; entry-warning. As you add/remove all digits (considered invalid for + ; user-errors. As you add/remove all digits (considered invalid for ; demonstration purposes) the menu item becomes available/unavailable ; appropriately. ; @@ -406,7 +408,7 @@ (lambda () (format t "~&Load pressed"))))) (mk-menu-entry-command :label "Save" - :state (c? (if (entry-warning (fm^ :ltk-test)) + :state (c? (if (user-errors (fm^ :point-ct)) :disabled :normal)) :command (c? (tk-callback .tkw 'save (lambda () (format t "~&Save pressed"))))) @@ -432,3 +434,23 @@ :command "exit")))))) +(defmodel entry-numeric (entry) + ((num-parse :initarg :num-parse :accessor num-parse + :initform (c? (eko ("numparse") + (handler-case + (parse-integer (^md-value)) + (parse-error (c) + (princ-to-string c)))))) + (num-value :initarg :num-value :accessor num-value + :initform (c? (if (numberp (^num-parse)) + (^num-parse) + (or .cache 42))))) + (:default-initargs + :md-value "42" + :user-errors (c? (unless (numberp (^num-parse)) + (^num-parse))))) + + +(defun mk-entry-numeric (&rest iargs) + (apply 'make-instance 'entry-numeric :fm-parent *parent* iargs)) +

1 0

[cells-cvs] CVS Celtk
by ktilton 25 Mar '06

25 Mar '06

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$)

1 0

[cells-cvs] CVS Celtk
by ktilton 24 Mar '06

24 Mar '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv13791 Modified Files: Celtk.lisp ltktest-cells-inside.lisp tk-format.lisp Log Message: --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/24 03:46:25 1.7 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/24 12:09:44 1.8 @@ -123,8 +123,9 @@ rpt) ;; a little redundant since bwhen checks that rpt is not nil (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters (setf (id self) (after (^delay) (lambda () - (funcall (^action) self) - (setf (^executed) t)))))))))))) + (when (eq (^state) :on) + (funcall (^action) self) + (setf (^executed) t))))))))))))) (defobserver timers ((self tk-object) new-value old-value) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/24 03:46:25 1.7 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/24 12:09:44 1.8 @@ -341,9 +341,9 @@ :repeat (c-in nil) :delay 25 ;; milliseconds since this gets passed unvarnished to TK after :action (lambda (timer) - (when (eq (state timer) :on) - (incf (^angle-1) 0.1)))))) - :coords (c? (let* ((angle-2 (* 0.3 (^angle-1))) + (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)) --- /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/24 03:46:25 1.4 +++ /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/24 12:09:44 1.5 @@ -56,6 +56,7 @@ (trc nil "!!! --- tk-user-queue-handler dispatching" defer-info) (funcall task))) +#+debug (defun tk-format-now (fmt$ &rest fmt-args &aux (tk$ (apply 'format nil fmt$ fmt-args))) ; ; --- pure debug stuff --- @@ -77,6 +78,11 @@ (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$) + (force-output (wish-stream *wish*))) + (defun tk-format (defer-info fmt$ &rest fmt-args) "Format then send to wish (via user queue)" (assert (or (eq defer-info :grouped)

1 0

[cells-cvs] CVS Celtk
by ktilton 24 Mar '06

24 Mar '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv13477 Modified Files: CELTK.lpr Celtk.asd Celtk.lisp canvas.lisp composites.lisp demos.lisp ltktest-cells-inside.lisp menu.lisp textual.lisp tk-format.lisp widgets.lisp Removed Files: ltk-kt.lisp Log Message: Remove ltk-kt.lisp, modify celtk.asd to depend on Ltk classic, modify licenses/copyright/attribution in all source. --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/24 03:46:25 1.3 @@ -5,7 +5,8 @@ (defpackage :CELTK) (define-project :name :celtk - :modules (list (make-instance 'module :name "ltk-kt.lisp") + :modules (list (make-instance 'module :name + "C:\\0devtools\\ltk\\ltk.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.asd 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/03/24 03:46:25 1.3 @@ -12,10 +12,9 @@ :licence "MIT Style" :description "Tk via LTk with Cells Inside(tm)" :long-description "A Cells-driven portable GUI built atop the LTk core, ultimately implmented by Tk" - :depends-on (:cells) + :depends-on (:ltk :cells) :serial t - :components ((:file "ltk-kt") - (:file "Celtk") + :components ((:file "Celtk") (:file "tk-format") (:file "menu") (:file "textual") --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/23 20:57:53 1.6 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/24 03:46:25 1.7 @@ -1,31 +1,32 @@ -#| - - Celtic / widget.lisp : Foundation classes - - Copyright (c) 2004 by Kenneth William Tilton <ktilton(a)nyc.rr.com> - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): - - (http://opensource.franz.com/preamble.html) - - 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 - Lisp Lesser GNU Public License for more details. - -|# +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. (defpackage :celtk (:nicknames "CTK") (:use :common-lisp :utils-kt :cells) (:import-from #:ltk - #:wish-stream #:*wish* #:*ewish* - #:peek-char-no-hang #:read-data #:event-root-x #:event-root-y + #: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) @@ -52,6 +53,7 @@ (in-package :Celtk) + (defmodel tk-object (model) ((.md-name :cell nil :initform (gentemp "TK") :initarg :id) (tk-class :cell nil :initform nil :initarg :tk-class :reader tk-class) --- /project/cells/cvsroot/Celtk/canvas.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/canvas.lisp 2006/03/24 03:46:25 1.2 @@ -1,23 +1,24 @@ -#| - - Celtic / frame.lisp - - Copyright (c) 2004 by Kenneth William Tilton <ktilton(a)nyc.rr.com> - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): - - (http://opensource.franz.com/preamble.html) - - 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 - Lisp Lesser GNU Public License for more details. - -|# +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. (in-package :Celtk) --- /project/cells/cvsroot/Celtk/composites.lisp 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/03/24 03:46:25 1.3 @@ -1,23 +1,25 @@ -#| +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. - Celtic / widget.lisp : Foundation classes - - Copyright (c) 2004 by Kenneth William Tilton <ktilton(a)nyc.rr.com> - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): - - (http://opensource.franz.com/preamble.html) - - 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 - Lisp Lesser GNU Public License for more details. - -|# (in-package :Celtk) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/03/22 18:50:08 1.3 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/03/24 03:46:25 1.4 @@ -1,24 +1,24 @@ -#| - - Celtic - - Copyright (c) 2004 by Kenneth William Tilton <ktilton(a)nyc.rr.com> - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): - - (http://opensource.franz.com/preamble.html) - - 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 - Lisp Lesser GNU Public License for more details. - -|# - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. (in-package :celtk-user) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/23 20:57:53 1.6 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/24 03:46:25 1.7 @@ -1,3 +1,35 @@ +#| + + This software is Copyright (c) 2003, 2004, 2005, 2006 Peter Herth <herth(a)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) #| --- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/23 18:25:24 1.4 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/24 03:46:25 1.5 @@ -1,23 +1,25 @@ -#| - - Celtic - - Copyright (c) 2004 by Kenneth William Tilton <ktilton(a)nyc.rr.com> - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. - (http://opensource.franz.com/preamble.html) - - 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 - Lisp Lesser GNU Public License for more details. - -|# (in-package :Celtk) --- /project/cells/cvsroot/Celtk/textual.lisp 2006/03/23 18:25:24 1.3 +++ /project/cells/cvsroot/Celtk/textual.lisp 2006/03/24 03:46:25 1.4 @@ -1,23 +1,25 @@ -#| +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. - Celtic / textual.lisp - - Copyright (c) 2004 by Kenneth William Tilton <ktilton(a)nyc.rr.com> - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): - - (http://opensource.franz.com/preamble.html) - - 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 - Lisp Lesser GNU Public License for more details. - -|# (in-package :Celtk) --- /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/22 18:50:08 1.3 +++ /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/24 03:46:25 1.4 @@ -1,24 +1,24 @@ -#| - - Celtic / tk-format.lisp : Sending code to Tk - - Copyright (c) 2004 by Kenneth William Tilton <ktilton(a)nyc.rr.com> - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): - - (http://opensource.franz.com/preamble.html) - - 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 - Lisp Lesser GNU Public License for more details. - -|# - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. (in-package :Celtk) --- /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/22 05:26:22 1.2 +++ /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/24 03:46:25 1.3 @@ -1,23 +1,25 @@ -#| +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk; -*- +;;; +;;; Copyright (c) 2006 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. - Celtic / button.lisp - - Copyright (c) 2004 by Kenneth William Tilton <ktilton(a)nyc.rr.com> - - A work derived from Peter Herth's LTk. As a derived work, - usage is governed by LTk's "Lisp LGPL" licensing: - - You have the right to distribute and use this software as governed by - the terms of the Lisp Lesser GNU Public License (LLGPL): - - (http://opensource.franz.com/preamble.html) - - 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 - Lisp Lesser GNU Public License for more details. - -|# (in-package :Celtk)

1 0

[cells-cvs] CVS Celtk
by ktilton 24 Mar '06

24 Mar '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv5257 Modified Files: ltk-kt.lisp Log Message: Modify ltk-kt.lisp copyright notice to indicate ltk-kt.lisp has been modified. --- /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/22 18:50:08 1.3 +++ /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/24 02:34:16 1.4 @@ -14,7 +14,20 @@ 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 file was modified by Kenny !!!!!!!!!!!!!!! +!!!!!!!!!!!! Tilton on March 22, 2006: !!!!!!!!!!!!!!! +!!!!!!!!!!!! !!!!!!!!!!!!!!! +!!!!!!!!!!!! better handling of TK errors !!!!!!!!!!!!!!! +!!!!!!!!!!!! commented out the demo !!!!!!!!!!!!!!! +!!!!!!!!!!!! !!!!!!!!!!!!!!! +!!!!!!!!!!!! !!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + |# #|

1 0

[cells-cvs] CVS Celtk
by ktilton 23 Mar '06

23 Mar '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv29683 Modified Files: Celtk.lisp ltktest-cells-inside.lisp Log Message: getting a little fancier on the entry widget in ltktest-cells-inside --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/23 18:25:24 1.5 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/23 20:57:53 1.6 @@ -274,8 +274,8 @@ into slot-defs when tk-option collecting `(defobserver ,slot-name ((self ,class)) - (when (and new-value old-value-boundp) - (tk-configure self ,(string tk-option) new-value))) + (when old-value-boundp + (tk-configure self ,(string tk-option) (or new-value "")))) into outputs finally (return (values slot-defs outputs))) `(progn --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/23 18:25:24 1.5 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/23 20:57:53 1.6 @@ -163,7 +163,20 @@ :relief 'sunken) (mk-label :text "Test:") (mk-button-ex ("OK:" (setf (moire-spin (fm^ :moire-1)) 20)))) - (mk-entry :id :entry) + (mk-entry :id :entry + :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 + ; + ; 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)))) ; ; fm^v -> (md-value (fm^ ....

1 0

[cells-cvs] CVS Celtk
by ktilton 23 Mar '06

23 Mar '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv11130 Modified Files: Celtk.lisp ltktest-cells-inside.lisp menu.lisp textual.lisp Log Message: Final touches on Celtk, the ltktest-cells-inside demo, and the doc in ltktest-cells-inside.lisp. --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/23 04:22:08 1.4 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/23 18:25:24 1.5 @@ -75,37 +75,54 @@ ;;; - the executions rule is true obfuscated code. It manages to reset the count to zero ;;; on repeated (setf ... 20)'s because on the second repetition we know we will hit the rule ;;; with repeat non-null (20, in fact) and the ephemeral executed will be nil (because it is -;;; only non-nil during propagation of (setf (executed...) t). +;;; only non-nil during propagation of (setf (executed...) t). not for Cell noobs. ;;; ;;; - holy toledo. The /rule/ for after-factory sends the after command to Tk itself! I could just ;;; return a list of the delay and the callback and have an observer dispatch it, but it would ;;; have to so so exactly as the rule does, by dropping it in the deferred client queue. -;;; so do it in the rule, I decide. +;;; In a sense I am starting here to leverage Cells3 queues to simplify things. Mind you, if +;;; Timer evolves to where we let the client write its own after factory, we might want to +;;; factor out the actual dispatch into an observer to make it transparent (assuming that is +;;; not why they are supplying their own after-factory. +;;; +;;; Timer is totally a work-in-progress with much development ahead. +;;; (defmodel timer () ((id :cell nil :initarg :id :accessor id :initform nil - :documentation "We use this as well as a flag that an AFTER is outstanding") - (tag :cell nil :initarg :tag :accessor tag :initform :anon) - (state :initarg :state :accessor state :initform (c-in :on)) - (action :initform nil :initarg :action :accessor action) - (delay :initform 0 :initarg :delay :accessor delay) - (repeat :initform (c-in nil) :initarg :repeat :accessor repeat :unchanged-if 'never-unchanged) - (executed :cell :ephemeral :initarg :executed :accessor executed :initform (c-in nil)) + :documentation "Assigned by TCL after each AFTER issued. Use to cancel.") + (tag :cell nil :initarg :tag :accessor tag :initform :anon + :documentation "A debugging aid") + (state :initarg :state :accessor state :initform (c-in :on) + :documentation "Turn off to stop, regardless of REPEAT setting") + (action :initform nil :initarg :action :accessor action + :documentation "A function (to which the timer is passed) invoked by when the TCL AFTER executes") + (delay :initform 0 :initarg :delay :accessor delay + :documentation "Millisecond interval supplied as is to TCL AFTER") + (repeat :initform (c-in nil) :initarg :repeat :accessor repeat :unchanged-if 'never-unchanged + :documentation "t = run continuously, nil = pause, a number N = repeat N times") + (executed :cell :ephemeral :initarg :executed :accessor executed :initform (c-in nil) + :documentation "Internal: set after an execution") (executions :initarg :executions :accessor executions + :documentation "Number of times timer has had its action run since the last change to the repeat slot" :initform (c? (if (null (^repeat)) - 0 + 0 ;; ok, repeat is off, safe to reset the counter here (if (^executed) - (1+ .cache ) - 0)))) - (after-factory :initform (c? (when (and (eq (^state) :on) - (let ((execs (^executions))) ;; odd reference just to establish dependency when repeat is t - (bwhen (rpt (^repeat)) - (or (eql rpt t) - (< execs rpt)))) ;; it better be a number - (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters - (setf (id self) (after (^delay) (lambda () - (funcall (^action) self) - (setf (^executed) t))))))))))) + (1+ (or .cache 0)) ;; obviously (.cache is the prior value, and playing it safe in case unset) + 0)))) ;; hunh? executed is ephemeral. we are here only if repeat is changed, so reset + + (after-factory + :documentation "Pure implementation" + :initform (c? (bwhen (rpt (when (eq (^state) :on) + (^repeat))) + (when (or (zerop (^executions)) (^executed)) ;; dispatch initially or after an execution + (when (if (numberp rpt) + (< (^executions) rpt) + rpt) ;; a little redundant since bwhen checks that rpt is not nil + (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters + (setf (id self) (after (^delay) (lambda () + (funcall (^action) self) + (setf (^executed) t)))))))))))) (defobserver timers ((self tk-object) new-value old-value) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/23 04:22:08 1.4 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/23 18:25:24 1.5 @@ -4,6 +4,12 @@ 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. + +Second topic: + How is programming with Cells different from without Cells? Those questions are different because not everything different about Celtk @@ -11,6 +17,11 @@ The pattern will be to have 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 @@ -21,23 +32,25 @@ ; - make .x the -textvariable of .y ; - set .x to "Hi, Mom" ; - ; Tk does not like Step 3 going before Step 2. 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. That is a big win when it works. But when it did not - ; I created the concept of a so-called "client queue" where client-code could store - ; order-sensitive tasks, and then allowed the client also to specify the handler for + ; 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. That is + ; a big win when it works. But when it did not work for Tk I added to Cells the concept + ; of a "client queue" where client-code could store + ; order-sensitive tasks, also allowing the client to specify the handler for ; that queue. This handler gets called at just the right time in the larger scheme of - ; state propagation one needs for data integrity. Whassat? + ; state propagation one needs for data integrity. What is that? ; - ; Data integrity: when the overall data model gets perturbed by a SETF by imperative code - ; (usually processing an event loop) of some datapoint X , we need: + ; Data integrity: when the overall data model gets perturbed by imperative code + ; (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 state) must be recomputed; - ; - no recomputation can use datapoints not current with the new value of X; - ; - when invoking client observers to process a change in a datapoint, no observer can use - ; any datapoint not current with X; and a corrollary: - ; - should a client observer itself want to SETF a datapoint Y, all the above must - ; happen not just with values current with X, but also current with the value of Y /prior/ + ; - all state computed off X (directly or indirectly through some intermediate datapoint) must be recomputed; + ; - 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 + ; happen with values current not just with X, but also with the value of Y /prior/ ; to the intended change to Y. ; ; To achieve the above, Cells2 and now Cells3 have taken to using FIFO "unfinished business" queues @@ -56,8 +69,19 @@ ; automatically by the Cells engine. See DEFOBSERVER. (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) + collect c)) + (format nil "Please! No 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. + ; + :documentation "Demonstrate live tracking of entry edit")) + (:default-initargs + :id :ltk-test :kids (c? ; c? has one hell of an expansion. In effect one gets: ; - a first-class anonymous function with the expected body, which will have access to @@ -65,25 +89,25 @@ ; computed value, if any ; - guaranteed recomputation when the value of any other cell used in the computation changes ; - ; The abbreviation-challenged use c-formula instead of c?, with different syntax I do not recall + ; If the abbreviation bothers 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 deets of the-kids are of negligible interest. + ; 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>). - ; Where you see, say, mk-button-ex (a) I am poking fun at Microsoft naming of second generation + ; 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 need to recreate the ltktest demo. Other packing is handled via two + ; 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 @@ -105,7 +129,7 @@ ; 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 subwidgets contained (packed or gridded) within the frame. + ; be kids/subwidgets contained (packed or gridded) within the frame. ; (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Rotation:") @@ -122,12 +146,15 @@ ; anywhere in the tree.) ; ; OK, now what is going on here? The above command starts the canvas display - ; spinning, by tweaking the "repeat" slot of a "moire" (new ad hoc class) object - ; I created to render the pretty design from + ; 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"))) @@ -148,10 +175,49 @@ ; ; 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 + ; 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. ; - (mk-button-ex ("set!" (setf (fm^v :entry) "test of set")))))))) + (mk-button-ex ("set!" (setf (fm^v :entry) "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 + ; 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 + ; 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. + ))))) - +(defobserver entry-warning () + ; + ; This demonstrates ones ability to track the text in a Tk entry while it is being + ; edited. As you type you should see the changing values in standard output + ; + (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))))) (defmodel ltk-test-canvas (canvas) () @@ -188,8 +254,8 @@ ; ; here is a limitation with the declarative paradigm. pop-up menus are free to float about ; unpacked in any parent. One just needs to remember the name of the menu widget to - ; pass it to the pop-up function. So imperative code like ltktest original can just make the menus - ; saving their name in a local variable and then refer to them in a callback to pop them up. + ; pass it to the pop-up function. So imperative code like ltktest "classic" can just make the menus + ; saving their name in a closed-over local variable and then refer to them in a callback to pop them up. ; ; in the declarative paradigm we need a slot (defined for any widget or item class) in which ; to build and store such menus: @@ -214,30 +280,48 @@ :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) - ((rotx :initarg :rotx :accessor rotx :initform (c-in 0))) + ((angle-1 :initarg :angle-1 :accessor angle-1 :initform (c-in 0))) (:default-initargs :timers (c? (list (make-instance 'timer - :state (c-in :on) - :repeat (c-in nil) - :delay 25 ;; milliseconds since this gets passed to TK after - :action (lambda (timer) - (when (eq (state timer) :on) - (incf (^rotx))))))) - :coords (c? (let* ((angle (* 0.1 (^rotx))) - (angle2 (* 0.3 angle)) - (wx (sin (* 0.1 angle)))) + ; + ; 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 nil) + :delay 25 ;; milliseconds since this gets passed unvarnished to TK after + :action (lambda (timer) + (when (eq (state timer) :on) + (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 (* i 2.8001)) - for x = (+ (* 50 (sin angle2)) 250 (* 150 (sin w) (1+ wx))) - for y = (+ (* 50 (cos angle2)) 200 (* 150 (cos w))) + 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)) + (setf (repeat (car (timers self))) repeat)) ;; just hiding the implementation (defun ltk-test-menus () + ; + ; The only difference is that the menu structure as seen by the user + ; is apparent here, which might help some when reorganizing menus. + ; + ; Well, another thing which happens not to be visible here... hang on. + ; OK, I just made the Save menu item contingent upon there being no + ; entry-warning. As you add/remove all digits (considered invalid for + ; demonstration purposes) the menu item becomes available/unavailable + ; appropriately. + ; + ; This is the kind of thing that Cells is good for. + ; (mk-menubar :kids (c? (the-kids (mk-menu-entry-cascade-ex (:label "File") @@ -246,6 +330,8 @@ (lambda () (format t "~&Load pressed"))))) (mk-menu-entry-command :label "Save" + :state (c? (if (entry-warning (fm^ :ltk-test)) + :disabled :normal)) :command (c? (tk-callback .tkw 'save (lambda () (format t "~&Save pressed"))))) (mk-menu-entry-separator) @@ -260,7 +346,13 @@ (lambda () (format t "~&Png pressed")))))) (mk-menu-entry-separator) (mk-menu-entry-command :label "Quit" - :accelerator "<Alt-q>" + :accelerator "Alt-q" + ; + ; check out the observer on the accelerator slot of the class menu-entry-usable + ; to see how Celtk fills in a gap in Tk: accelerators should work just by + ; declaring them to the menu widget, it seems to me. In Celtk, they do. + ; :underline 1 :command "exit")))))) + --- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/22 18:50:08 1.3 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/23 18:25:24 1.4 @@ -140,7 +140,7 @@ (call-next-method) (with-integrity (:client '(:bind nil)) (when new-value - (tk-format-now "bind . ~a {~a invoke ~a}" new-value (path (upper self menu)) (index self))))) + (tk-format-now "bind . <~a> {~a invoke ~a}" new-value (path (upper self menu)) (index self))))) (deftk menu-entry-cascade (selector family menu-entry-usable) --- /project/cells/cvsroot/Celtk/textual.lisp 2006/03/22 05:26:22 1.2 +++ /project/cells/cvsroot/Celtk/textual.lisp 2006/03/23 18:25:24 1.3 @@ -68,7 +68,7 @@ (:default-initargs :id (gentemp "ENT") :textvariable (c? (^path)) - :md-value (c-in "<your string here>"))) + :md-value (c-in ""))) (defmethod md-awaken :after ((self entry)) (tk-format `(:trace ,self) "trace add variable ~a write \"trc2 ~a\""

1 0