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

[cells-cvs] CVS cells/utils-kt
by ktilton 23 Mar '06

23 Mar '06

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv23415/utils-kt Modified Files: utils-kt.lpr Log Message: --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/03/16 05:26:47 1.5 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/03/23 04:22:56 1.6 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2006 20:04)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Mar 19, 2006 10:49)"; cg: "1.81"; -*- (in-package :cg-user)

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

1 0

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

22 Mar '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv27411 Modified Files: ltktest-cells-inside.lisp Log Message: --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 18:50:08 1.2 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 20:41:37 1.3 @@ -1,18 +1,73 @@ (in-package :celtk-user) +#| +The comments throughout this source file cover two broad topics: + + How is programming with Celtk different from LTk? + How is programming with Cells different from without Cells? + +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. + +|# #+test-ltktest (progn (cells-reset 'tk-user-queue-handler) + ; + ; Tk is fussy about the order in which things happen. It likes: + ; - create widgets .x and .y + ; - 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 + ; that queue. This handler gets called at just the right time in the larger scheme of + ; state propagation one needs for data integrity. Whassat? + ; + ; 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: + ; + ; - 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/ + ; to the intended 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 + ; 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: + ; + ; - 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)) +; 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 +; automatically by the Cells engine. See DEFOBSERVER. + (defmodel ltktest-cells-inside (window) - ((elapsed :initarg :elapsed :accessor elapsed :initform (c-in 0))) + () (:default-initargs :kids (c? (the-kids - (ltk-test-menus) + ; + ; Cells GUIs get a lot of mileage out of the family class, which is perfect + ; for graphical hierarchies. + ; + (ltk-test-menus) ;; hiding some code. see below for deets (mk-scroller - :packing (c?pack-self "-side top -fill both -expand 1") - :canvas (c? (make-kid 'ltk-test-canvas))) + :packing (c?pack-self "-side top -fill both -expand 1") + :canvas (c? (make-kid 'ltk-test-canvas))) + (mk-row (:packing (c?pack-self "-side bottom")) (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Rotation:") @@ -67,7 +122,7 @@ :timers (c? (when (^repeat) (list (make-instance 'timer :tag :moire - :delay 1 + :delay 25 :repeat (let ((m self)) (c? (repeat m))) :action (lambda (timer)

1 0

[cells-cvs] CVS cells/utils-kt
by ktilton 22 Mar '06

22 Mar '06

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv26836/utils-kt Added Files: datetime.lisp Log Message: --- /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2006/03/22 20:36:38 NONE +++ /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2006/03/22 20:36:38 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- ;;; ;;; ;;; Copyright © 1995,2003 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 :utils-kt) (eval-when (compile load eval) (export '(os-tickcount time-of-day now hour-min-of-day time-in-zone dd-mmm-yy mmm-dd-yyyy))) (defun os-tickcount () (cl:get-internal-real-time)) (defun now () (/ (get-internal-real-time) internal-time-units-per-second)) (defun time-of-day (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~A:~2,,,'0@A:~2,,,'0@A" hours minutes seconds))) (defun hour-min-of-day (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~2,,,'0@A:~2,,,'0@A" hours minutes))) (defun time-in-zone (inzone &optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylightsavingsp this-zone) (decode-universal-time i-time) (declare (ignorable this-zone day-of-week daylightsavingsp)) (encode-universal-time seconds minutes hours date month year (- inzone (if daylightsavingsp 1 0))))) (defun dd-mmm-yy (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~A-~A-~2,,,'0@A" date (month-abbreviation month) (mod year 100)))) (defun mmm-dd-yyyy (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~A ~A, ~A" (month-abbreviation month) date year))) (eval-when (compile load eval) (export '(month-abbreviation weekday-abbreviation week-time mdyy-yymd u-time u-date))) (defun month-abbreviation (month) (elt '("Jan" "Feb" "Mar" "Apr" "May" "June" "July" "Aug" "Sept" "Oct" "Nov" "Dec") (1- month))) (defun weekday-abbreviation (day) (elt '("Mon" "Tue" "Wed" "Thur" "Fri" "Sat" "Sun") day)) (defun week-time (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~A ~A ~A, ~A ~a:~2,'0d ~a" (weekday-abbreviation day-of-week) (month-abbreviation month) date year (if (= 12 hours) hours (mod hours 12)) ; JP 010911 since (mod 12 12) = 0, treat 12 as a special case. minutes (if (>= hours 12) "PM" "AM")))) (defun mdyy-yymd (d) (assert (eql 8 (length d))) (conc$ (right$ d 4) (left$ d 4))) (defun u-time (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~2,d:~2,'0d ~a" ;; /// time-zone, really Naggum's stuff (mod hours 12) minutes (if (>= hours 12) "PM" "AM")))) (defun u-date (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~A-~A-~A" date (elt '("Jan" "Feb" "Mar" "Apr" "May" "June" "July" "Aug" "Sept" "Oct" "Nov" "Dec") (1- month)) year ))) (eval-when (compile load eval) (export '(u-day multiple-value-bind m/d/y mm/dd yyyy-mm-dd))) (defun u-day (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (elt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") day-of-week))) (defun u-day3 (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (elt '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") day-of-week))) (defun m/d/y (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~2,,,'0@A/~2,,,'0@A/~2,,,'0@A" month date (mod year 100)))) (defun mm/dd (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~2,,,'0@A/~2,,,'0@A" month date))) (defun yyyy-mm-dd (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~4,,,'0@A~2,,,'0@A~2,,,'0@A" year month date))) (eval-when (compile load eval) (export '(ymdhmsh))) (defun ymdhmsh (&optional (i-time (get-universal-time))) (multiple-value-bind (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone) (decode-universal-time i-time) (declare (ignorable seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)) (format nil "~4,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A:~2,,,'0@A" year month date hours minutes seconds (floor (now) 10)))) (defun hyphenated-time-string () (substitute #\- #\: (ymdhmsh)))

1 0

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

22 Mar '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv11856 Modified Files: Celtk.lisp demos.lisp load.lisp ltk-kt.lisp ltktest-cells-inside.lisp menu.lisp tk-format.lisp Log Message: Finishing touches getting ltktest demo fully equivalent to original pure LTk version. Added auto-bind of menu accelerator, and improved the hack to get the OK button working sensibly. --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/22 18:50:08 1.3 @@ -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)) + #:tk-user-queue-handler #:timer #:make-timer-steps)) (defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) @@ -64,6 +64,8 @@ ;;; --- timers ---------------------------------------- +(defstruct timer-steps count) + (defmodel timer () ((id :initarg :id :accessor id :initform (c? (bwhen (spawn (^spawn)) @@ -87,6 +89,8 @@ (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))) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/03/22 18:50:08 1.3 @@ -23,25 +23,23 @@ (in-package :celtk-user) -(defun ctk::tk-test () - (cells-reset 'tk-user-queue-handler) +(defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (tk-test-class 'ltktest-cells-inside)) -(defparameter *tktest* nil) - (defun tk-test-class (root-class) + (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)\"}") (setf ltk:*debug-tk* nil) (with-integrity () - (time (setf *tktest* (make-instance root-class)))) + (make-instance root-class)) (tk-format `(:fini) "wm deiconify ."))) -(defun tk-test-all ()(tk-test-class 'a-few)) +(defun tk-test-all ()(tk-test-class 'lotsa-widgets)) (defun mk-font-view () (make-instance 'font-view)) -(defmodel a-few (window) +(defmodel lotsa-widgets (window) () (:default-initargs :kids (c? (the-kids @@ -56,7 +54,7 @@ :width 300 :image (c? (format nil "~(~a.~a~)" (ctk::^path) 'kt))) - ;;(assorted-canvas-items) + (assorted-canvas-items) (mk-stack () (mk-text-widget @@ -67,7 +65,7 @@ (spin-package-with-symbols)) - #+nahh (mk-stack () + (mk-stack () (mk-row (:id :radio-ny :selection (c-in 'yes)) (mk-radiobutton-ex ("yes" 'yes)) (mk-radiobutton-ex ("no" 'no)) @@ -79,7 +77,7 @@ (mk-label :text (c? (if (fm^v :check-me) "checked" "unchecked")))) (mk-row () (mk-button-ex ("Time now?" (setf (fm!v :push-time) - (get-universal-time)))) + (get-universal-time)))) (mk-label :text (c? (time-of-day (^md-value))) :id :push-time :md-value (c-in (get-universal-time)))) @@ -93,7 +91,7 @@ :id :enter-me) (mk-label :text (c? (conc$ "echo " (fm^v :enter-me)))))) - #+nahh (duelling-scrolled-lists) + (duelling-scrolled-lists) ))))) (defun style-by-edit-menu () --- /project/cells/cvsroot/Celtk/load.lisp 2006/03/22 05:26:21 1.2 +++ /project/cells/cvsroot/Celtk/load.lisp 2006/03/22 18:50:08 1.3 @@ -1,13 +1,15 @@ #+eval-this-if-you-do-not-autoload-asdf -(load (make-pathname :device "c" +(load (make-pathname #+lispworks :host #-lispworks :device "c" :directory '(:absolute "0dev" "cells") :name "asdf" :type "lisp")) -(push (make-pathname :device "c" :directory '(:absolute "0dev" "cells")) +(push (make-pathname #+lispworks :host #-lispworks :device "c" + :directory '(:absolute "0dev" "cells")) asdf:*central-registry*) -(push (make-pathname :device "c" :directory '(:absolute "0dev" "Celtk")) +(push (make-pathname #+lispworks :host #-lispworks :device "c" + :directory '(:absolute "0dev" "Celtk")) asdf:*central-registry*) #-runtestsuite @@ -22,3 +24,5 @@ #+testceltk (ctk::tk-test) +#+ortestceltk +(celtk-user::tk-test-class 'celtk-user::lotsa-widgets) \ No newline at end of file --- /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/22 05:26:22 1.2 +++ /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/22 18:50:08 1.3 @@ -357,6 +357,7 @@ (defparameter *ewish* nil) (defun do-execute (program args &optional (wt nil)) + (declare (ignorable wt)) "execute program with args " #+:clisp (declare (ignore wt)) (let ((fullstring program)) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 05:26:22 1.1 +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 18:50:08 1.2 @@ -17,18 +17,15 @@ (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Rotation:") (mk-button-ex ("Start" (setf (repeat (fm^ :moire-1)) t))) - (mk-button-ex ("Stop" (progn (trc "killing running!!!!!!!!!!") - (setf (repeat (fm^ :moire-1)) nil))))) - (mk-button-ex ("Hallo" (format T "Hallo~%"))) - (mk-button-ex ("Welt!" (format T "Welt~%"))) + (mk-button-ex ("Stop" (setf (repeat (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:" (progn ;; I do not like this - (setf (repeat (fm^ :moire-1)) 0) - (setf (repeat (fm^ :moire-1)) 20))))) + (mk-button-ex ("OK:" (setf (repeat (fm^ :moire-1)) (make-timer-steps :count 20))))) (mk-entry :id :entry) - (mk-button-ex ("get!" (format t "~&content of entry: ~A~%" (fm^v :entry)))) + (mk-button-ex ("get!" (format t "~&content of entry: ~A" (fm^v :entry)))) (mk-button-ex ("set!" (setf (fm^v :entry) "test of set")))))))) (defmodel ltk-test-canvas (canvas) @@ -70,7 +67,7 @@ :timers (c? (when (^repeat) (list (make-instance 'timer :tag :moire - :delay 25 + :delay 1 :repeat (let ((m self)) (c? (repeat m))) :action (lambda (timer) @@ -92,23 +89,24 @@ (mk-menu-entry-cascade-ex (:label "File") (mk-menu-entry-command :label "Load" :command (c? (tk-callback .tkw 'load - (lambda () (format t "~&Load pressed~&"))))) + (lambda () (format t "~&Load pressed"))))) (mk-menu-entry-command :label "Save" :command (c? (tk-callback .tkw 'save - (lambda () (format t "Save pressed~&"))))) + (lambda () (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~&"))))) + (lambda () (format t "~&Jpeg pressed"))))) (mk-menu-entry-command :label "png" :command (c? (tk-callback .tkw 'png - (lambda () (format t "Png pressed~&")))))) + (lambda () (format t "~&Png pressed")))))) (mk-menu-entry-separator) (mk-menu-entry-command :label "Quit" - :accelerator "Alt Q" + :accelerator "<Alt-q>" + :underline 1 :command "exit")))))) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/22 05:26:22 1.2 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/22 18:50:08 1.3 @@ -136,6 +136,13 @@ -compound -font -foreground -hidemargin -image -label -state -underline)) +(defobserver accelerator :around ((self menu-entry-usable)) + (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))))) + + (deftk menu-entry-cascade (selector family menu-entry-usable) () (:tk-spec cascade --- /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/22 05:26:22 1.2 +++ /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/22 18:50:08 1.3 @@ -60,12 +60,14 @@ ; ; --- pure debug stuff --- ; - (let ((yes '( "scroll")) ;; '("scroll" "pkg-sym")) + (let ((yes '( "bind" "invoke")) ;; '("scroll" "pkg-sym")) (no '())) (declare (ignorable yes no)) - (when nil #+not (and (find-if (lambda (s) (search s tk$)) yes) + (bwhen (st (search "\"Alt Q\"" tk$)) + (replace tk$ "{Alt Q}" :start1 st)) + (when (and (find-if (lambda (s) (search s tk$)) yes) (not (find-if (lambda (s) (search s tk$)) no))) - (format t "~&tk[~a] ~a> ~A~%" dbg #+nah cells::*data-pulse-id* defer-info tk$) + (format t "~&tk> ~A~%" #+nah cells::*data-pulse-id* tk$) #+nah (unless (find #\" tk$) (break "bad set ~a" tk$)))) (assert (wish-stream *wish*)) ;; when not?? @@ -108,4 +110,3 @@ (defmethod parent-path ((nada null)) "") (defmethod parent-path ((self t)) (^path)) -

1 0

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

22 Mar '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv11734 Modified Files: propagate.lisp Log Message: defobserver now supports an :around option specified in usual place: (defobserver accelerator :around () etc......) Long overdue. --- /project/cells/cvsroot/cells/propagate.lisp 2006/03/18 00:15:40 1.10 +++ /project/cells/cvsroot/cells/propagate.lisp 2006/03/22 18:48:13 1.11 @@ -112,37 +112,39 @@ ; --- slot change ----------------------------------------------------------- -(defmacro defobserver (slotname - (&optional (self-arg 'self) (new-varg 'new-value) - (oldvarg 'old-value) (oldvargboundp 'old-value-boundp)) - &body output-body) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (get ',slotname :output-defined) t)) - ,(if (eql (last1 output-body) :test) - (let ((temp1 (gensym)) - (loc-self (gensym))) - `(defmethod slot-value-observe #-(or clisp cormanlisp) progn ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) - (let ((,temp1 (bump-output-count ,slotname)) - (,loc-self ,(if (listp self-arg) - (car self-arg) - self-arg))) - (when (and ,oldvargboundp ,oldvarg) - (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg)) - (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg)))) - `(defmethod slot-value-observe - #-(or clisp cormanlisp) progn ;;broke cells-gtk #+(or clisp cormanlisp) :around - ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) - (declare (ignorable - ,@(flet ((arg-name (arg-spec) - (etypecase arg-spec - (list (car arg-spec)) - (atom arg-spec)))) - (list (arg-name self-arg)(arg-name new-varg) - (arg-name oldvarg)(arg-name oldvargboundp))))) - ,@output-body - ;;broke cells-gtk #+(or clisp cormanlisp) (call-next-method) - )))) +(defmacro defobserver (slotname &rest args &aux (aroundp (eq :around (first args)))) + (when aroundp (setf args (cdr args))) + (destructuring-bind ((&optional (self-arg 'self) (new-varg 'new-value) + (oldvarg 'old-value) (oldvargboundp 'old-value-boundp)) + &body output-body) args + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (get ',slotname :output-defined) t)) + ,(if (eql (last1 output-body) :test) + (let ((temp1 (gensym)) + (loc-self (gensym))) + `(defmethod slot-value-observe #-(or clisp cormanlisp) ,(if aroundp :around 'progn) + ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) + (let ((,temp1 (bump-output-count ,slotname)) + (,loc-self ,(if (listp self-arg) + (car self-arg) + self-arg))) + (when (and ,oldvargboundp ,oldvarg) + (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg)) + (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg)))) + `(defmethod slot-value-observe + #-(or clisp cormanlisp) ,(if aroundp :around 'progn) + ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) + (declare (ignorable + ,@(flet ((arg-name (arg-spec) + (etypecase arg-spec + (list (car arg-spec)) + (atom arg-spec)))) + (list (arg-name self-arg)(arg-name new-varg) + (arg-name oldvarg)(arg-name oldvargboundp))))) + ,@output-body + ;;broke cells-gtk #+(or clisp cormanlisp) (call-next-method) + ))))) (defmacro bump-output-count (slotname) ;; pure test func `(if (get ',slotname :outputs)

1 0

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

22 Mar '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv5902 Modified Files: load.lisp Log Message: --- /project/cells/cvsroot/cells/load.lisp 2006/03/22 04:08:34 1.3 +++ /project/cells/cvsroot/cells/load.lisp 2006/03/22 05:26:53 1.4 @@ -7,8 +7,18 @@ (push (make-pathname :device "c" :directory '(:absolute "0dev" "cells")) asdf:*central-registry*) +(push (make-pathname :device "c" :directory '(:absolute "0dev" "Celtk")) + asdf:*central-registry*) + #-runtestsuite -(ASDF:OOS 'ASDF:LOAD-OP :CELLS :force t) +(ASDF:OOS 'ASDF:LOAD-OP :CELLS) #+runtestsuite -(ASDF:OOS 'ASDF:LOAD-OP :CELLS-TEST :force t) \ No newline at end of file +(ASDF:OOS 'ASDF:LOAD-OP :CELLS-TEST) + +#+checkoutceltk +(ASDF:OOS 'ASDF:LOAD-OP :CELTK) + +#+testceltk +(ctk::tk-test) +

1 0

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

22 Mar '06

Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv5809 Modified Files: CELTK.lpr Celtk.asd Celtk.lisp composites.lisp demos.lisp load.lisp ltk-kt.lisp menu.lisp textual.lisp tk-format.lisp widgets.lisp Added Files: ltktest-cells-inside.lisp Log Message: --- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/03/22 05:26:21 1.2 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2006 20:04)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Mar 19, 2006 10:49)"; cg: "1.81"; -*- (in-package :cg-user) @@ -6,15 +6,16 @@ (define-project :name :celtk :modules (list (make-instance 'module :name "ltk-kt.lisp") - (make-instance 'module :name "notes.lisp") (make-instance 'module :name "Celtk.lisp") (make-instance 'module :name "tk-format.lisp") (make-instance 'module :name "menu.lisp") - (make-instance 'module :name "composites.lisp") (make-instance 'module :name "textual.lisp") (make-instance 'module :name "widgets.lisp") (make-instance 'module :name "canvas.lisp") - (make-instance 'module :name "demos.lisp")) + (make-instance 'module :name "composites.lisp") + (make-instance 'module :name "demos.lisp") + (make-instance 'module :name + "ltktest-cells-inside.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\cells")) :libraries nil --- /project/cells/cvsroot/Celtk/Celtk.asd 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/03/22 05:26:21 1.2 @@ -18,8 +18,10 @@ (:file "Celtk") (:file "tk-format") (:file "menu") - (:file "composites") (:file "textual") (:file "widgets") (:file "canvas") - (:file "demos"))) + (:file "composites") + (:file "demos") + (:file "ltktest-cells-inside"))) + --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/03/22 05:26:21 1.2 @@ -24,25 +24,28 @@ (:use :common-lisp :utils-kt :cells) (:import-from #:ltk - #:wish-stream #:*wish* #:*ewish* "*DEBUG-TK*" - #:peek-char-no-hang #:read-data - #:send-wish #:tkescape + #:wish-stream #:*wish* #:*ewish* + #:peek-char-no-hang #:read-data #:event-root-x #:event-root-y + #:send-wish #:tkescape #:after #:after-cancel #:bind #:with-ltk #:do-execute #:add-callback) - (:export #:window #:panedwindow #:mk-row #:pack-self #:mk-stack #:mk-text-widget + (:export + #:pop-up #:event-root-x #:event-root-y + #: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 - #:frame-stack #:mk-frame-stack #:pack-layout? #:path + #:mk-checkbutton #:mk-button #:mk-button-ex #: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 #:mk-menu-entry-cascade #:mk-menubar + #: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 - #:mk-polygon #:mk-oval #:mk-line #:mk-arc #:mk-text-item - #:mk-rectangle #:mk-bitmap #:mk-canvas #:mk-frame-row + #:polygon #:mk-polygon #:oval #:mk-oval #:line #:mk-line #:arc #:mk-arc #:text-tem #: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)) + #:tk-user-queue-handler #:timer)) (defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) @@ -51,13 +54,49 @@ (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))) + (tk-class :cell nil :initform nil :initarg :tk-class :reader tk-class) + (timers :initarg :timers :accessor timers :initform nil))) (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self)) (define-symbol-macro .tkw (nearest self window)) +;;; --- timers ---------------------------------------- + +(defmodel timer () + ((id :initarg :id :accessor id + :initform (c? (bwhen (spawn (^spawn)) + (apply 'after spawn)))) + (tag :cell nil :initarg :tag :accessor tag :initform :anon) + (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) + (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 + (number (when (< (^executions)(^repeat)) + (spawn-delayed (^delay)))) + (cons (bwhen (delay (nth (^executions) (^repeat))) + (spawn-delayed delay))) + (otherwise (spawn-delayed (^delay)))))))))))) + +(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? + ;;; --- widget ----------------------------------------- @@ -67,9 +106,11 @@ (format nil "~(~a.~a~)" (parent-path (fm-parent self)) (md-name self)))) - (layout :reader layout :initarg :layout :initform nil) + (packing :reader packing :initarg :packing :initform nil) + (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) (image-files :reader image-files :initarg :image-files :initform nil) (selector :reader selector :initarg :selector :initform (c? (upper self selector)))) @@ -82,33 +123,38 @@ (tk-format `(:make-tk ,self) "~(~a~) ~a ~{~(~a~) ~a~^ ~}" (tk-class self) (path self)(tk-configurations self)) :stdfctry)) -;;;(defmethod md-awaken :before ((self widget)) -;;; (loop for (name file-pathname) in (^image-files) -;;; do (tk-format "image create photo ~(~a.~a~) -file ~a" -;;; (^path) name (tkescape (namestring file-pathname))))) +(defmethod tk-configure ((self widget) option value) + (tk-format `(:configure ,self ,option) "~a configure ~(~a~) ~a" (path self) option (tk-send-value value))) -(defobserver image-files () +(defmethod not-to-be :after ((self widget)) + (trc nil "not-to-be tk-forgetting true widget" self) + (tk-format `(:forget ,self) "pack forget ~a" (^path)) + (tk-format `(:destroy ,self) "destroy ~a" (^path))) + +;;; --- bindings ------------------------------------------------------------ + +(defobserver bindings () ;;; (w widget) event fun) ; - ; I do not know how to create the photo for X before X exists - ; though it seems to work. <g> perhaps Tk understands it does not need to - ; place the image in a tree and lets the undefined path go? If so, - ; just add :pre-make-kt before :make-kt in the sort list + ; when we get dynamic with this cell we will have to do the kids + ; thing and worry about extant new-values, de-bind lost old-values ; - (loop for (name file-pathname) in (set-difference new-value old-value :key 'car) - do (tk-format `(:pre-make-tk ,self) "image create photo ~(~a.~a~) -file ~a" - (^path) name (tkescape (namestring file-pathname))))) + (with-integrity (:client `(:bind ,self)) + (dolist (bspec new-value) + (if (eql (length bspec) 3) ;; getting wierd here + (destructuring-bind (event fmt fn) bspec + (let ((name (gentemp "BNDG"))) + (tk-format `(:bind ,self) "bind ~a ~a ~a" ;; {puts {:callback ~a}}" + (^path) event (format nil fmt (register-callback self name fn))))) + (destructuring-bind (event fn) bspec + (bind (^path) event fn)))))) -(defobserver bindings () ;;; (w widget) event fun) - (loop for (event fmt fn) in new-value - for name = (gentemp "BNDG") - do (tk-format `(:bind ,self) "bind ~a ~a ~a" ;; {puts {:callback ~a}}" - (^path) event (format nil fmt (register-callback self name fn))))) +;;; --- packing --------------------------------------------------------- -(defobserver layout ((self widget)) +(defobserver packing ((self widget)) (when new-value - (assert (null (kids-layout .parent)) () - "Do not specify layout (here for ~a) unless parent leaves kids-layout unspecified. -This parent is ~a, kids-layout ~a" self (list .parent (type-of .parent)) (kids-layout .parent))) + (assert (null (kids-packing .parent)) () + "Do not specify packing (here for ~a) unless parent leaves kids-packing unspecified. +This parent is ~a, kids-packing ~a" self (list .parent (type-of .parent)) (kids-packing .parent))) ; ; This use next of the parent instead of self is pretty tricky. It has to do with getting ; the pack commands out nested widgets before parents. The pack command issued on behalf @@ -122,17 +168,27 @@ (when (and new-value (not (typep .parent 'panedwindow))) (tk-format `(:pack ,(fm-parent self)) new-value))) -(defun pack-self () - (c? (format nil "pack ~a" (path self)))) +(defmacro c?pack-self (&optional (modifier$ "")) + `(c? (format nil "pack ~a ~a" (path self) ,modifier$))) -(defmethod tk-configure ((self widget) option value) - (tk-format `(:configure ,self ,option) "~A configure ~(~a~) ~a" (path self) option (tk-send-value value))) +;;; --- grids ------------------------------------------------------------------------- -(defmethod not-to-be :after ((self widget)) - (trc nil "not-to-be tk-forgetting true widget" self) - (tk-format `(:forget ,self) "pack forget ~a" (^path)) - (tk-format `(:destroy ,self) "destroy ~a" (^path))) +(defmodel grid-manager ()()) +(defobserver gridding ((self grid-manager)) + (when new-value + (loop for k in (^kids) + when (gridding k) + do (tk-format `(:grid ,k) (format nil "grid ~a ~a" (path k) (gridding k)))) + (destructuring-bind (&key columns rows) new-value + (when columns + (loop for config in columns + for idx upfrom 0 + do (tk-format `(:grid ,self) (format nil "grid columnconfigure ~a ~a ~a" (^path) idx config)))) + (when columns + (loop for config in rows + for idx upfrom 0 + do (tk-format `(:grid ,self) (format nil "grid rowconfigure ~a ~a ~a" (^path) idx config))))))) ;;; --- items ----------------------------------------------------------------------- @@ -230,7 +286,7 @@ (defun tk-callback (self id-suffix fn &optional command) (declare (ignorable command)) (let ((id (register-callback self id-suffix fn))) - (trc nil "tk-callback" self id command) + (trc nil "tk-callback" self id) (list 'callback id))) (defun tk-callbackstring (self id-suffix tk-token fn) @@ -291,3 +347,21 @@ (tk-variable self) (tk-send-value new-value)))) +;;; --- images ------------------------------------------------------- + +(defobserver image-files () + ; + ; I do not know how to create the photo for X before X exists + ; though it seems to work. <g> perhaps Tk understands it does not need to + ; place the image in a tree and lets the undefined path go? If so, + ; just add :pre-make-kt before :make-kt in the sort list + ; + (loop for (name file-pathname) in (set-difference new-value old-value :key 'car) + do (tk-format `(:pre-make-tk ,self) "image create photo ~(~a.~a~) -file ~a" + (^path) name (tkescape (namestring file-pathname))))) + + +;;; --- menus --------------------------------- + +(defun pop-up (menu x y) + (tk-format-now "tk_popup ~A ~A ~A" (path menu) x y)) \ No newline at end of file --- /project/cells/cvsroot/Celtk/composites.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/03/22 05:26:21 1.2 @@ -51,7 +51,7 @@ -showhandle) (:default-initargs :id (gentemp "PW") - :layout nil)) + :packing nil)) (defmethod make-tk-instance ((self panedwindow)) (tk-format `(:make-tk ,self) "panedwindow ~a -orient ~(~a~)" @@ -67,7 +67,10 @@ ; -------------------------------------------------------- -(defmodel window (family) +(defmodel composite-widget (widget) + ((kids-packing :initarg :kids-packing :accessor kids-packing :initform nil))) + +(defmodel window (composite-widget) ((wish :initarg :wish :accessor wish :initform (wish-stream *wish*) #+(or) (c? (do-execute "wish84 -name testwindow" @@ -82,47 +85,46 @@ (defmethod path ((self window)) ".") (defmethod parent-path ((self window)) "") -(defmethod kids-layout ((self window)) nil) ;--- group geometry ----------------------------------------- -(defmodel inline-mixin () - ((kids-layout :initarg :kids-layout :accessor kids-layout :initform nil) - (padx :initarg :padx :accessor padx :initform 0) +(defmodel inline-mixin (composite-widget) + ((padx :initarg :padx :accessor padx :initform 0) (pady :initarg :pady :accessor pady :initform 0) - (layout-side :initarg :layout-side :accessor layout-side :initform 'left) + (packing-side :initarg :packing-side :accessor packing-side :initform 'left) (layout-anchor :initarg :layout-anchor :accessor layout-anchor :initform 'nw)) (:default-initargs :kid-slots (lambda (self) (declare (ignore self)) (list - (mk-kid-slot (layout :if-missing t) + (mk-kid-slot (packing :if-missing t) nil))) ;; suppress default - :kids-layout (c? (format nil "pack~{ ~a~} -side ~a -anchor ~a -padx ~a -pady ~a" - (mapcar 'path (^kids)) - (down$ (^layout-side)) - (down$ (^layout-anchor)) - (^padx)(^pady))))) + :kids-packing (c? (when (^kids) + (format nil "pack~{ ~a~} -side ~a -anchor ~a -padx ~a -pady ~a" + (mapcar 'path (^kids)) + (down$ (^packing-side)) + (down$ (^layout-anchor)) + (^padx)(^pady)))))) -(defobserver kids-layout () +(defobserver kids-packing () (when new-value - (tk-format `(:pack ,self kids-layout) new-value))) + (tk-format `(:pack ,self kids-packing) new-value))) (defmodel row-mixin (inline-mixin) () (:default-initargs - :layout-side 'left)) + :packing-side 'left)) (defmodel stack-mixin (inline-mixin) () (:default-initargs - :layout-side 'top)) + :packing-side 'top)) ;--- f r a m e -------------------------------------------------- -(deftk frame () +(deftk frame (composite-widget) () (:tk-spec frame -borderwidth -cursor -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief @@ -168,3 +170,38 @@ (def-mk-inline mk-row (frame-row labelframe-row)) (def-mk-inline mk-stack (frame-stack labelframe-stack)) + +;--- scroller (of canvas; need to generalize this) ---------- + +(defmodel scroller (grid-manager frame) + ((canvas :initarg :canvas :accessor canvas :initform nil)) + (:default-initargs + :id :cv-scroller + :kids-packing nil + :gridding '(:columns ("-weight {1}" "-weight {0}") + :rows ("-weight {1}" "-weight {0}")) + :kids (c? (the-kids + (^canvas) + (mk-scrollbar :id :hscroll + :orient "horizontal" + :gridding "-row 1 -column 0 -sticky we" + :command (c? (format nil "~a xview" (path (kid1 .parent))))) + (mk-scrollbar :id :vscroll + :orient "vertical" + :gridding "-row 0 -column 1 -sticky ns" + :command (c? (format nil "~a yview" (path (kid1 .parent))))))))) + +(defmacro mk-scroller (&rest iargs) + `(make-instance 'scroller + :fm-parent self + ,@iargs)) + +(defmethod initialize-instance :after ((self scroller) &key) + ; + ; Tk does not do late binding on widget refs, so the canvas cannot mention the scrollbars + ; in x/y scrollcommands since the canvas gets made first + ; + (with-integrity (:client `(:post-make-tk ,self)) + (setf (xscrollcommand (kid1 self)) (format nil "~a set" (path (fm! :hscroll)))) + (setf (yscrollcommand (kid1 self)) (format nil "~a set" (path (fm! :vscroll)))))) + --- /project/cells/cvsroot/Celtk/demos.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/03/22 05:26:21 1.2 @@ -20,22 +20,22 @@ |# + (in-package :celtk-user) (defun ctk::tk-test () - (tk-test-class 'a-few)) + (cells-reset 'tk-user-queue-handler) + (tk-test-class 'ltktest-cells-inside)) (defparameter *tktest* nil) (defun tk-test-class (root-class) - (cells-reset 'tk-user-queue-handler) - (setf ctk::*tk-send-ct* 0) (with-ltk (:debug 0) (send-wish "proc trc2 {cb n1 n2 op} {puts \"(:callback \\\"$cb\\\" :name1 $n1 :name2 \\\"$n2\\\" :op $op)\"}") - (setf ltk::*debug-tk* nil) - (time (setf *tktest* (make-instance root-class))) - (tk-format `(:fini) "wm deiconify .") - )) + (setf ltk:*debug-tk* nil) + (with-integrity () + (time (setf *tktest* (make-instance root-class)))) + (tk-format `(:fini) "wm deiconify ."))) (defun tk-test-all ()(tk-test-class 'a-few)) (defun mk-font-view () @@ -47,7 +47,7 @@ :kids (c? (the-kids (demo-all-menubar) - (mk-row (:layout (pack-self)) + (mk-row (:packing (c?pack-self)) (mk-label :text "aaa" :image-files (list (list 'kt (make-pathname #+lispworks :host #-lispworks :device "c" :directory '(:absolute "0dev" "Celtk") @@ -56,7 +56,7 @@ :width 300 :image (c? (format nil "~(~a.~a~)" (ctk::^path) 'kt))) - (assorted-canvas-items) + ;;(assorted-canvas-items) (mk-stack () (mk-text-widget @@ -65,9 +65,9 @@ :height 8 :width 25) - (spin-package-with-symbols)) + (spin-package-with-symbols)) - (mk-stack () + #+nahh (mk-stack () (mk-row (:id :radio-ny :selection (c-in 'yes)) (mk-radiobutton-ex ("yes" 'yes)) (mk-radiobutton-ex ("no" 'no)) @@ -93,7 +93,7 @@ :id :enter-me) (mk-label :text (c? (conc$ "echo " (fm^v :enter-me)))))) - (duelling-scrolled-lists) + #+nahh (duelling-scrolled-lists) ))))) (defun style-by-edit-menu () @@ -124,8 +124,11 @@ (item (when spinner (md-value spinner))) (pkg (find-package (string-upcase item)))) (when pkg - (loop for sym being the present-symbols in pkg - collecting sym)))) + (loop for sym being the symbols in pkg + counting sym into symct + collecting sym into syms + finally (trc "syms found !!!" symct) + (return syms))))) :list-item-factory (lambda (sym) (make-instance 'listbox-item :fm-parent *parent* @@ -191,7 +194,7 @@ (defun style-by-widgets () (mk-stack ("Style by Widgets" :id :widstyle) (mk-row (:id :stywid - :layout-side 'left + :packing-side 'left :layout-anchor 'sw) (mk-popup-menubutton :id :font-face @@ -277,7 +280,7 @@ (:default-initargs :kids (c? (the-kids (mk-panedwindow - :layout (pack-self) + :packing (c?pack-self) :orient 'vertical :kids (c? (the-kids (loop repeat 2 @@ -288,9 +291,8 @@ (:default-initargs :md-value (c? (tk-eval-list self "font families")) :pady 2 :padx 4 - :layout-side 'left + :packing-side 'left :layout-anchor 'nw - ;;:kids-layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") :kids (c? (the-kids (mk-spinbox :id :font-face :md-value (c-in (car (^md-value))) @@ -311,14 +313,7 @@ ;;; ---- toplevel -------------------------------- -(defmodel tl-popper (frame-stack) - () - (:default-initargs - :pady 2 :padx 4 - :layout (pack-layout? "-side left -fill both -expand 1 -anchor nw") - :kids (c? (the-kids - (mk-button-ex ("Open" (make-instance 'file-open)) - :underline 0))))) + (defmodel file-open (toplevel) --- /project/cells/cvsroot/Celtk/load.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/load.lisp 2006/03/22 05:26:21 1.2 @@ -1,3 +1,4 @@ +#+eval-this-if-you-do-not-autoload-asdf (load (make-pathname :device "c" :directory '(:absolute "0dev" "cells") :name "asdf" @@ -7,10 +8,17 @@ asdf:*central-registry*) (push (make-pathname :device "c" :directory '(:absolute "0dev" "Celtk")) - asdf:*central-registry*) + asdf:*central-registry*) + +#-runtestsuite +(ASDF:OOS 'ASDF:LOAD-OP :CELLS) + +#+runtestsuite +(ASDF:OOS 'ASDF:LOAD-OP :CELLS-TEST) -(ASDF:OOS 'ASDF:LOAD-OP :Celtk :force t) +#+checkoutceltk +(ASDF:OOS 'ASDF:LOAD-OP :CELTK) -#+gratuitousfeature +#+testceltk (ctk::tk-test) --- /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/ltk-kt.lisp 2006/03/22 05:26:22 1.2 @@ -517,26 +517,26 @@ ;;; start wish and set (wish-stream *wish*) (defun start-wish (&rest keys &key handle-errors handle-warnings (debugger t) - stream) + stream) (declare (ignore handle-errors handle-warnings debugger)) ;; open subprocess (if (null (wish-stream *wish*)) (progn - (setf (wish-stream *wish*) (or stream (do-execute *wish-pathname* *wish-args*)) - (wish-call-with-condition-handlers-function *wish*) - (apply #'make-condition-handler-function keys)) - ;; perform tcl initialisations + (setf (wish-stream *wish*) (or stream (do-execute *wish-pathname* *wish-args*)) + (wish-call-with-condition-handlers-function *wish*) + (apply #'make-condition-handler-function keys)) + ;; perform tcl initialisations (with-ltk-handlers () (init-wish))) - ;; By default, we don't automatically create a new connection, because the - ;; user may have simply been careless and doesn't want to push the old - ;; connection aside. The NEW-WISH restart makes it easy to start another. - (restart-case (ltk-error "There is already an inferior wish.") - (new-wish () - :report "Create an additional inferior wish." - (push *wish* *wish-connections*) - (setf *wish* (make-ltk-connection)) - (apply #'start-wish keys))))) + ;; By default, we don't automatically create a new connection, because the + ;; user may have simply been careless and doesn't want to push the old + ;; connection aside. The NEW-WISH restart makes it easy to start another. + (restart-case (ltk-error "There is already an inferior wish.") + (new-wish () + :report "Create an additional inferior wish." + (push *wish* *wish-connections*) + (setf *wish* (make-ltk-connection)) + (apply #'start-wish keys))))) (defun exit-wish () (with-ltk-handlers () @@ -619,7 +619,7 @@ (handler-case (or (let ((event (pop (wish-event-queue *wish*)))) - (when event (ukt:trc "read-event > popq" event)) + ;; (when event (ukt:trc "read-event > popq" event)) event) (if (or blocking (can-read (wish-stream *wish*))) --- /project/cells/cvsroot/Celtk/menu.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/03/22 05:26:22 1.2 @@ -57,6 +57,9 @@ :grandpar (fm-parent .parent) (type-of (fm-parent .parent))) (tk-format `(:make-tk ,self) "menu ~a -tearoff 0" (^path))) +(defmacro mk-menu-ex (&rest submenus) + `(mk-menu :kids (c? (the-kids ,@submenus)))) + (defmethod make-tk-instance :after ((self menu)) (trc nil "make-tk-instance > traversing menu" self) (fm-menu-traverse self @@ -140,6 +143,11 @@ (:default-initargs :menu (c? (path (kid1 self))))) +(defmacro mk-menu-entry-cascade-ex ((&rest initargs) &rest submenus) + `(mk-menu-entry-cascade + ,@initargs + :kids (c? (the-kids (mk-menu :kids (c? (the-kids ,@submenus))))))) + (defmethod path ((self menu-entry-cascade)) (format nil "~(~a.~a~)" (path .parent) (md-name self))) --- /project/cells/cvsroot/Celtk/textual.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/textual.lisp 2006/03/22 05:26:22 1.2 @@ -70,16 +70,13 @@ :textvariable (c? (^path)) :md-value (c-in "<your string here>"))) -;;;(defmethod make-tk-instance ((self entry)) -;;; (setf (gethash (^path) (dictionary .tkw)) self) -;;; (tk-format "entry ~a -textvariable ~a" (path self)(path self))) - (defmethod md-awaken :after ((self entry)) (tk-format `(:trace ,self) "trace add variable ~a write \"trc2 ~a\"" (^path) (register-callback self 'tracewrite (lambda (&key name1 name2 op) (declare (ignorable name1 name2 op)) + (trc nil "tracewrite BINGO!!!!" (^path) (tk-eval-var (^path))) (let ((new-value (tk-eval-var (^path)))) (unless (string= new-value (^md-value)) (setf (^md-value) new-value))))))) --- /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/tk-format.lisp 2006/03/22 05:26:22 1.2 @@ -25,11 +25,9 @@ ; --- tk-format --- talking to wish/Tk ----------------------------------------------------- -(defparameter *tk-send-ct* 0) - (defun tk-user-queue-sort (task1 task2) "Intended for use as user queue sorter, to make Tk happy by giving it stuff in the order it needs to work properly." - (let ((priority '(:destroy :pre-make-tk :make-tk :post-make-tk :variable :bind :selection :trace :configure :pack :fini))) + (let ((priority '(:destroy :pre-make-tk :make-tk :post-make-tk :variable :bind :selection :trace :configure :grid :pack :fini))) (destructuring-bind (type1 self1 &rest dbg) task1 (declare (ignorable dbg)) (assert type1) @@ -58,45 +56,39 @@ (trc nil "!!! --- tk-user-queue-handler dispatching" defer-info) (funcall task))) -(defun tk-format (defer-info fmt$ &rest fmt-args &aux (tk$ (apply 'format nil fmt$ fmt-args))) +(defun tk-format-now (fmt$ &rest fmt-args &aux (tk$ (apply 'format nil fmt$ fmt-args))) + ; + ; --- pure debug stuff --- + ; + (let ((yes '( "scroll")) ;; '("scroll" "pkg-sym")) + (no '())) + (declare (ignorable yes no)) + (when nil #+not (and (find-if (lambda (s) (search s tk$)) yes) + (not (find-if (lambda (s) (search s tk$)) no))) + (format t "~&tk[~a] ~a> ~A~%" dbg #+nah cells::*data-pulse-id* defer-info tk$) + #+nah (unless (find #\" tk$) + (break "bad set ~a" tk$)))) + (assert (wish-stream *wish*)) ;; when not?? + ; + ; --- serious stuff --- + ; + (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) - (consp defer-info)) () "need defer-info to sort command ~a. Specify :grouped if caller is managing user-queue" tk$) - - ;; sigh, it can happen outside a path (assert (not (search "nil" tk$)) () "What is NIL doing in TK message ~a?" tk$) + (consp defer-info)) () "need defer-info to sort command ~a. Specify :grouped if caller is managing user-queue" + (apply 'format nil fmt$ fmt-args)) (when (eq defer-info :grouped) (setf defer-info nil)) - - (flet ((core (dbg) - (declare (ignorable dbg)) - ; - ; --- pure debug stuff --- - ; - (let ((yes '("font-face")) - (no '("pkg-sym-list"))) - (declare (ignorable yes no)) - (when nil #+bzzt (and (find-if (lambda (s) (search s tk$)) yes) - (not (find-if (lambda (s) (search s tk$)) no))) - (format t "~&tk[~a] ~a> ~A~%" dbg #+nah cells::*data-pulse-id* defer-info tk$) - #+nah (unless (find #\" tk$) - (break "bad set ~a" tk$)))) - (assert (wish-stream *wish*)) ;; when not?? - ; - ; --- serious stuff --- - ; - (format (wish-stream *wish*) "~A~%" tk$) - (force-output (wish-stream *wish*)) - ; - ; --- mo better debug ----------------- - ; - #+sighh (loop - while (peek-char-no-hang *ewish*) - do (break "ewish!!!!!!!> ~a" (read-line defun*ewish* nil nil))))) + (flet ((do-it () + (apply 'tk-format-now fmt$ fmt-args))) (if defer-info (with-integrity (:client defer-info) - (core :wi)) - (core :im)))) + (do-it)) + (do-it)))) (defmethod tk-send-value ((s string)) (format nil "~s" #+not "{~a}" s)) @@ -113,9 +105,6 @@ (defmethod tk-send-value ((values list)) (format nil "{~{~a~^ ~}}" (mapcar 'tk-send-value values))) -(defmacro pack-layout? (fmt$ &rest args) - `(c? (format nil "pack ~a ~?" (^path) ,fmt$ (list ,@args)))) - (defmethod parent-path ((nada null)) "") (defmethod parent-path ((self t)) (^path)) --- /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/16 05:15:14 1.1 +++ /project/cells/cvsroot/Celtk/widgets.lisp 2006/03/22 05:26:22 1.2 @@ -42,8 +42,8 @@ `(make-instance 'button :fm-parent *parent* :text ,text - :command (tk-callback self 'cmd - (lambda () ,command)) + :command (c? (tk-callback self 'cmd + (lambda () ,command))) ,@initargs)) ; --- checkbutton --------------------------------------------- @@ -196,9 +196,9 @@ (defobserver initial-value ((self spinbox)) (when new-value - (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value) - - (setf (^md-value) new-value))) + (with-integrity (:change) + (trc "spinbox intializing from initvalue !!!!!!!!!!!!" self new-value) + (setf (^md-value) new-value)))) ; --- scroll bars ---------------------------------------- @@ -223,7 +223,7 @@ (list-height :initarg :list-height :accessor list-height :initform nil)) (:default-initargs :list-height (c? (max 1 (length (^list-item-keys)))) - :kids-layout nil + :kids-packing nil :kids (c? (the-kids (mk-listbox :id :list-me :kids (c? (the-kids @@ -232,11 +232,11 @@ :font '(courier 9) :state (c? (if (enabled .parent) 'normal 'disabled)) :height (c? (list-height .parent)) - :layout (c? (format nil "pack ~a -side left -fill both -expand 1" (^path))) + :packing (c? (format nil "pack ~a -side left -fill both -expand 1" (^path))) :yscrollcommand (c? (when (enabled .parent) (format nil "~a set" (path (nsib)))))) (mk-scrollbar :id :vscroll - :layout (c? (format nil "pack ~a -side right -fill y" (^path))) + :packing (c?pack-self "-side right -fill y") :command (c? (format nil "~a yview" (path (psib))))))))) (defmethod tk-output-selection :after ((self scrolled-list) new-value old-value old-value-boundp) --- /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 05:26:22 NONE +++ /project/cells/cvsroot/Celtk/ltktest-cells-inside.lisp 2006/03/22 05:26:22 1.1 (in-package :celtk-user) #+test-ltktest (progn (cells-reset 'tk-user-queue-handler) (tk-test-class 'ltktest-cells-inside)) (defmodel ltktest-cells-inside (window) ((elapsed :initarg :elapsed :accessor elapsed :initform (c-in 0))) (:default-initargs :kids (c? (the-kids (ltk-test-menus) (mk-scroller :packing (c?pack-self "-side top -fill both -expand 1") :canvas (c? (make-kid 'ltk-test-canvas))) (mk-row (:packing (c?pack-self "-side bottom")) (mk-row (:borderwidth 2 :relief 'sunken) (mk-label :text "Rotation:") (mk-button-ex ("Start" (setf (repeat (fm^ :moire-1)) t))) (mk-button-ex ("Stop" (progn (trc "killing running!!!!!!!!!!") (setf (repeat (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:" (progn ;; I do not like this (setf (repeat (fm^ :moire-1)) 0) (setf (repeat (fm^ :moire-1)) 20))))) (mk-entry :id :entry) (mk-button-ex ("get!" (format t "~&content of entry: ~A~%" (fm^v :entry)))) (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)) (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")))))))) :kids (c? (the-kids (mk-text-item :coords (list 10 10) :anchor "nw" :text "Ltk Demonstration") (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))) (: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)) (incf (^rotx))))))) :coords (c? (let* ((angle (* 0.1 (^rotx))) (angle2 (* 0.3 angle)) (wx (sin (* 0.1 angle)))) (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))) nconcing (list x y)))))) (defun ltk-test-menus () (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" :command (c? (tk-callback .tkw 'save (lambda () (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-separator) (mk-menu-entry-command :label "Quit" :accelerator "Alt Q" :command "exit"))))))

1 0

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

22 Mar '06

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv26430 Modified Files: README.txt cells-test.asd cells.lpr defpackage.lisp load.lisp Log Message: More work on Cells and Celtk --- /project/cells/cvsroot/cells/README.txt 2005/05/06 21:05:45 1.1 +++ /project/cells/cvsroot/cells/README.txt 2006/03/22 04:08:34 1.2 @@ -12,18 +12,22 @@ of tracking dependencies among cells, and propagating values. It is distributed under an MIT-style license. -Documentation is unfortunately quite lacking; the cells-devel list is -still your best source of information. Some documentation can be -found in the doc/ directory of the distribution. See the website at -http://www.common-lisp.net/project/cells/ for more info. +Documentation/support is in the form of: + + the cells-devel mailing list (users and developers both welcome) + .\docs\01-cell-basics.lisp + .\docs\motor-control.lisp ;; actually Bill Clementson's blog entry + extensive examples in the Cells-test regression test suite + the companion Celtk module, which happens also to provide a substantial and + growing portable, native Common Lisp GUI. + +The above examples have all been tested against the current release of Cells. +Now in .\doc is cells-overview.pdf. That is pretty rough and obsolete in re the +code, but some of it might be enlightening. Cells is written in almost-portable ANSI Common Lisp. It makes very light use of the introspective portions of the MOP, and contains a few -workarounds for shortcomings in common implementations. It contains -gratuitous use of silly reader conditionals (eg, #-chya, #-not, etc), -so users wishing to push things like :TEST and :NOT on *FEATURES*, and -users of the New Implementation of Lisp (NIL) should beware. If the -last sentance didn't mean anything to you, you can ignore it. +workarounds for shortcomings in common implementations. Cells is known to currently work on the following Lisp implementations: @@ -43,7 +47,7 @@ a bug in its CLOS implementation, but has not been investigated in great depth. -Cells is belived to work with Corman CL, but has not been recently +Cells is believed to work with Corman CL, but has not been recently tested. In the past, MCL was supported, but a it does not currently pass the test suite. Ressurecting full support for any of these implementations should be easy. --- /project/cells/cvsroot/cells/cells-test.asd 2006/03/19 00:28:38 1.4 +++ /project/cells/cvsroot/cells/cells-test.asd 2006/03/22 04:08:34 1.5 @@ -10,7 +10,7 @@ :serial t :depends-on (:cells) :components ((:module "cells-test" - ;;:serial t + :serial t :components ((:file "test") (:file "hello-world") (:file "test-kid-slotting") --- /project/cells/cvsroot/cells/cells.lpr 2006/03/18 00:15:40 1.8 +++ /project/cells/cvsroot/cells/cells.lpr 2006/03/22 04:08:34 1.9 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2006 20:04)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Mar 19, 2006 10:49)"; cg: "1.81"; -*- (in-package :cg-user) --- /project/cells/cvsroot/cells/defpackage.lisp 2006/03/16 05:28:28 1.4 +++ /project/cells/cvsroot/cells/defpackage.lisp 2006/03/22 04:08:34 1.5 @@ -51,7 +51,7 @@ #:defmodel #:defobserver #:slot-value-observe #:def-c-unchanged-test #:new-value #:old-value #:old-value-boundp #:c... #:md-awaken - #:mkpart #:the-kids #:nsib #:md-value #:^md-value #:.md-value #:kids #:^kids #:.kids + #:mkpart #:make-kid #:the-kids #:nsib #:md-value #:^md-value #:.md-value #:kids #:^kids #:.kids #:cells-reset #:upper #:fm-max #:nearest #:fm-min-kid #:fm-max-kid #:mk-kid-slot #:def-kid-slots #:find-prior #:fm-pos #:kid-no #:fm-includes #:fm-ascendant-common #:fm-kid-containing #:fm-find-if #:fm-ascendant-if #:c-abs #:fm-collect-if #:psib --- /project/cells/cvsroot/cells/load.lisp 2006/03/16 05:28:28 1.2 +++ /project/cells/cvsroot/cells/load.lisp 2006/03/22 04:08:34 1.3 @@ -1,16 +1,14 @@ +#+eval-this-if-you-do-not-autoload-asdf (load (make-pathname :device "c" :directory '(:absolute "0dev" "cells") :name "asdf" :type "lisp")) -(progn - (push (make-pathname :device "c" :directory '(:absolute "0dev" "cells")) +(push (make-pathname :device "c" :directory '(:absolute "0dev" "cells")) asdf:*central-registry*) - (ASDF:OOS 'ASDF:LOAD-OP :CELLS :force t)) - -;;;(push (make-pathname :device "c" -;;; :directory '(:absolute "0dev" "cells" "cells-test")) -;;; asdf:*central-registry*) +#-runtestsuite +(ASDF:OOS 'ASDF:LOAD-OP :CELLS :force t) +#+runtestsuite (ASDF:OOS 'ASDF:LOAD-OP :CELLS-TEST :force t) \ No newline at end of file

1 0

[cells-cvs] CVS cells/cells-test
by ktilton 22 Mar '06

22 Mar '06

Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv26430/cells-test Modified Files: deep-cells.lisp Log Message: More work on Cells and Celtk --- /project/cells/cvsroot/cells/cells-test/deep-cells.lisp 2006/03/18 00:14:01 1.1 +++ /project/cells/cvsroot/cells/cells-test/deep-cells.lisp 2006/03/22 04:08:35 1.2 @@ -1,3 +1,5 @@ +(in-package :cells) + (defvar *client-log*) (defvar *obs-1-count*)

1 0