Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv23358

Modified Files: Celtk.lisp ltktest-cells-inside.lisp Log Message: Further documentation of Celtk in ltktest-cells-inside

--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/22 18:50:08 1.3 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/23 04:22:08 1.4 @@ -45,7 +45,7 @@ #: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 #:make-timer-steps)) + #:tk-user-queue-handler #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps))

(defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) @@ -64,42 +64,55 @@

;;; --- timers ----------------------------------------

-(defstruct timer-steps count) +(defun never-unchanged (new old) (declare (ignore new old))) + +;;; +;;; Now, not one but three incredibly hairy gyrations Cells-wise: +;;; +;;; - repeat cannot be ephemeral, but we want repeated (setf (^repeat) 20)'s each to fire, +;;; so we specify an unchanged-if value that always "no", lying to get propagation +;;; +;;; - 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). +;;; +;;; - 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.

(defmodel timer () - ((id :initarg :id :accessor id - :initform (c? (bwhen (spawn (^spawn)) - (apply 'after spawn)))) + ((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 1 :initarg :repeat :accessor repeat) - (completed :cell :ephemeral :initform (c-in nil) :initarg :completed :accessor completed) + (repeat :initform (c-in nil) :initarg :repeat :accessor repeat :unchanged-if 'never-unchanged) + (executed :cell :ephemeral :initarg :executed :accessor executed :initform (c-in nil)) (executions :initarg :executions :accessor executions - :initform (c? (+ (or .cache 0) - (if (^completed) 1 0)))) - (spawn :initarg :spawn :accessor spawn - :initform (c? (if (not (^action)) - (trc "Warning: timer with no associated action" self) - (flet ((spawn-delayed (n) - (list n (lambda () - (funcall (^action) self) - (setf (^completed) t))))) - (bwhen (repeat (^repeat)) - (when (or (zerop (^executions)) - (^completed)) - (typecase repeat - (timer-steps (when (< (^executions)(timer-steps-count (^repeat))) - (spawn-delayed (^delay)))) - (number (when (< (^executions)(^repeat)) - (spawn-delayed (^delay)))) - (cons (bwhen (delay (nth (^executions) (^repeat))) - (spawn-delayed delay))) - (otherwise (spawn-delayed (^delay)))))))))))) + :initform (c? (if (null (^repeat)) + 0 + (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))))))))))) +

(defobserver timers ((self tk-object) new-value old-value) (dolist (k (set-difference old-value new-value)) - (after-cancel (id k)))) ;; causes tk error if not outstanding? + (setf (state k) :off) + (when (id self) + (after-cancel (id k))))) ;; Tk doc says OK if cancelling already executed

;;; --- widget -----------------------------------------

--- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 20:41:37 1.3 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/23 04:22:08 1.4 @@ -58,55 +58,155 @@ (defmodel ltktest-cells-inside (window) () (:default-initargs - :kids (c? (the-kids + :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 + ; - 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 + ; + (the-kids ; ; Cells GUIs get a lot of mileage out of the family class, which is perfect - ; for graphical hierarchies. + ; for graphical hierarchies. The deets of the-kids are of negligible interest. ; - (ltk-test-menus) ;; hiding some code. see below for deets + (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 + ; 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") - :canvas (c? (make-kid 'ltk-test-canvas))) + ; + ; 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 + ; 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 + ; class to see how this works. + ; + ; See the scroller class to see some automation of grids (but this was my first experience + ; with grids so look for that to get enhanced over time -- and later automation + ; of the use of PLACE. + ; + :canvas (c? (make-kid 'ltk-test-canvas))) ;; hiding some code. see defmodel thereof below + ; + ; My bad. Scroller should not assume a canvas is the scrollee. To be refined. + ; +

(mk-row (:packing (c?pack-self "-side bottom")) + ; + ; Just expand mk-row to see what is going on. It is pretty neat in one respect: if the + ; 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. + ; (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Rotation:") - (mk-button-ex ("Start" (setf (repeat (fm^ :moire-1)) t))) - (mk-button-ex ("Stop" (setf (repeat (fm^ :moire-1)) nil)))) + (mk-button-ex ("Start" (setf (moire-spin (fm^ :moire-1)) t))) + ; + ; You were warned about mk-button-ex and its ilk above. + ; + ; 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 + ; 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 + ; 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 + ; 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)))) + + (mk-button-ex ("Hallo" (format T "~&Hallo"))) (mk-button-ex ("Welt!" (format T "~&Welt"))) (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Test:") - (mk-button-ex ("OK:" (setf (repeat (fm^ :moire-1)) (make-timer-steps :count 20))))) + (mk-button-ex ("OK:" (setf (moire-spin (fm^ :moire-1)) 20)))) (mk-entry :id :entry) (mk-button-ex ("get!" (format t "~&content of entry: ~A" (fm^v :entry)))) + ; + ; fm^v -> (md-value (fm^ .... + ; + ; 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 :entry) "test of set"))))))))

+ + (defmodel ltk-test-canvas (canvas) () (:default-initargs :id :test-canvas :scroll-region '(0 0 500 400) :gridding "-row 0 -column 0 -sticky news" - :xscrollcommand (c-in nil) ;; see initialize-instance of canvas for gory details - :yscrollcommand (c-in nil) - :bindings (c? (list (list "<1>" (lambda (event) - (pop-up (car (^menus)) + ; + ; As with packing, Celtk tries to simplify life with Tk gridding. But that is achieved partly + ; by automating things as with the kids-packing and kids-layout slots, and partly by staying + ; out of the programmer's way and letting them specify actual Tk code to be passed unfiltered + ; to Tk. The design choice here is to acknowledge that LTk and Celtk users really are still + ; doing Tk programming; only some automation (and Lispification) is provided. + ; + ; 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 needs 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" + ; + (pop-up (car (^menus)) ;; (^menus) -> (menus self) (event-root-x event) (event-root-y event)))))) - :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")))))))) + ; + ; 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 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. + ; + ; 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"))))))))

:kids (c? (the-kids (mk-text-item @@ -116,17 +216,14 @@ (make-kid 'moire :id :moire-1)))))

(defmodel moire (line) - ((rotx :initarg :rotx :accessor rotx :initform (c-in 0)) - (repeat :initarg :repeat :accessor repeat :initform (c-in nil))) + ((rotx :initarg :rotx :accessor rotx :initform (c-in 0))) (:default-initargs - :timers (c? (when (^repeat) - (list (make-instance 'timer - :tag :moire - :delay 25 - :repeat (let ((m self)) - (c? (repeat m))) - :action (lambda (timer) - (declare (ignore timer)) + :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)) @@ -137,6 +234,8 @@ for y = (+ (* 50 (cos angle2)) 200 (* 150 (cos w))) nconcing (list x y))))))

+(defun (setf moire-spin) (repeat self) + (setf (repeat (car (timers self))) repeat))

(defun ltk-test-menus () (mk-menubar