[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Thu Mar 23 04:22:08 UTC 2006
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
More information about the Cells-cvs
mailing list