Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv27500
Modified Files: Celtk.asd Celtk.lisp demos.lisp entry.lisp ltktest-ci.lisp multichoice.lisp run.lisp timer.lisp tk-interp.lisp widget.lisp Log Message: Celtk2 alpha release
--- /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/12 08:30:13 1.6 +++ /project/cells/cvsroot/Celtk/Celtk.asd 2006/05/16 02:52:22 1.7 @@ -15,7 +15,9 @@ :depends-on (:cells :cl-opengl :cl-glu) :serial t :components ((:file "Celtk") + (:file "tk-structs") (:file "tk-interp") + (:file "tk-events") (:file "tk-object") (:file "widget") (:file "font") @@ -35,6 +37,6 @@ (:file "frame") (:file "togl") (:file "run") - (:file "demos") (:file "ltktest-ci") - (:file "gears"))) + (:file "lotsa-widgets") + (:file "demos"))) --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/15 05:15:37 1.20 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/05/16 02:52:22 1.21 @@ -24,8 +24,8 @@ (:nicknames "CTK") (:use :common-lisp :utils-kt :cells :cffi) (:export - #:<1> - #:title$ #:pop-up #:event-root-x #:event-root-y + #:<1> #:tk-event-type #:xsv #:name #:x-root #:y-root + #:title$ #:pop-up #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:text-widget #:mk-panedwindow #:mk-stack #:mk-radiobutton #:mk-radiobutton-ex #:mk-radiobutton #:mk-label @@ -47,7 +47,7 @@ #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps #:^widget-menu #:widget-menu #:tk-format-now #:coords #:^coords #:tk-translate-keysym - #:do-on-event #:*tkw*)) + #:*tkw*))
(defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/15 05:15:37 1.14 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/16 02:52:22 1.15 @@ -25,10 +25,10 @@
(defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window - ;; 'one-button-window - ;;'ltktest-cells-inside - ;; OK 'menu-button-test - ;; OK 'spinbox-test + ;; true tester: 'one-button-window + ;; Not so good: 'ltktest-cells-inside + ;; 'menu-button-test + ;; 'spinbox-test 'lotsa-widgets ;; Now in Gears project 'gears-demo )) --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/15 05:15:37 1.6 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/16 02:52:22 1.7 @@ -46,18 +46,27 @@ :id (gentemp "ENT") :xscrollcommand (c-in nil) :textvariable (c? (intern (^path))) - :virtual-event-handlers (c? (list `(tracewrite ,(lambda (self event client-data) - (declare (ignore event client-data)) - (let ((new-value (tcl-get-var *tki* (^path) - (var-flags :TCL_GLOBAL_ONLY :TCL_LEAVE_ERR_MSG)))) - (unless (string= new-value (^md-value)) - (setf (^md-value) new-value))))))) + :event-handler (lambda (self xe) + (TRC nil "widget-event-handler" self (xsv type xe) ) + (case (tk-event-type (xsv type xe)) + (:virtualevent + (trc nil "v/e" (xsv name xe)) + (case (read-from-string (string-upcase (xsv name xe))) + (trace + (TRC nil "entry e/h trace" self (when (plusp (xsv user-data xe)) + (tcl-get-string (xsv user-data xe)))) + ;; assuming write op, but data field shows that + (let ((new-value (tcl-get-var *tki* (^path) + (var-flags :TCL_NAMESPACE_ONLY)))) + (unless (string= new-value (^md-value)) + (setf (^md-value) new-value))))))))
:md-value (c-in "")))
(defmethod md-awaken :after ((self entry)) ;; move this to a traces slot on widget (with-integrity (:client `(:trace ,self)) - (tk-format-now "trace add variable ~a write TraceOP" (^path)))) + (tk-format-now "trace add variable ~a write TraceOP" (^path)) + ))
;;; /// this next replicates the handling of tk-mirror-variable because ;;; those leverage the COMMAND mechanism, which entry lacks @@ -90,9 +99,14 @@ :yscrollcommand (c-in nil) :modified (c-in nil) :borderwidth (c? (if (^modified) 8 2)) - :virtual-event-handlers (c? (list `(modified ,(lambda (self event client-data) - (eko ("<<Modified>> !!TK value for text-widget" self event client-data) - (setf (^modified) t)))))))) + :event-handler (lambda (self xe) + (case (tk-event-type (xsv type xe)) + (:virtualevent + (case (read-from-string (string-upcase (xsv name xe))) + (modified + (eko (nil "<<Modified>> !!TK value for text-widget" self) + (setf (^modified) t))))))))) + ;;;(defvar +tk-keysym-table+ ;;; (let ((ht (make-hash-table :test 'string=))) ;;; (with-open-file (ksyms "/0dev/math-paper/tk-keysym.dat" :direction :input) --- /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/15 05:15:37 1.4 +++ /project/cells/cvsroot/Celtk/ltktest-ci.lisp 2006/05/16 02:52:22 1.5 @@ -327,22 +327,13 @@ ; This also simplifies Celtk since it just has to pass the Tk code along with "grid <path> " ; appended. ; - :event-handlers nil #+not (c? (list - (list '(<1> "%X %Y") - (lambda (self event root-x root-y) - (declare (ignorable event root-x root-y)) - - ; - ; Stolen from the original. It means "when the left button is - ; pressed on this widget, popup this menu where the button was pressed" - ; The only difference is that here we get to specify this along with - ; the rest of the configuration of this instance, whereas in the original - ; the enabling code was just "out there" in a long sequence of other - ; imperatives setting up this widget and that. ie, It is nice having - ; everything about X collected in one place. In case you are wondering, - ; a standard event-handler is created for any widget with handlers. - ; - (pop-up (^widget-menu :bkg-pop) root-x root-y))))) + :event-handler (c? (lambda (self xe) + (case (tk-event-type (xsv type xe)) + (:virtualevent + (trc "canvas virtual" (xsv name xe))) + (:buttonpress + (TRC "canvas buttonpress" self (xsv x-root xe)(xsv y-root xe)) + (pop-up (^widget-menu :bkg-pop) (xsv x-root xe) (xsv y-root xe))))))
:menus (c? (the-kids ; --- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/15 05:15:37 1.5 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/16 02:52:22 1.6 @@ -69,16 +69,14 @@ :id (gentemp "LBX") :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) - :virtual-event-handlers - (c? (assert (selector self)) - (when (selector self) ;; if not? Figure out how listbox tracks own selection - (list `(ListboxSelect ,(lambda (self event client-data) - (declare (ignore client-data event)) - (trc "NEW listbox callback firing" self ) - (let ((selection (parse-integer (tk-eval "~a curselection" (^path))))) - (trc "NEW listbox selection" self selection) - (setf (selection (selector self)) - (md-value (elt (^kids) selection))))))))))) + :event-handler (lambda (self xe) + (case (tk-event-type (xsv type xe)) + (:virtualevent + (case (read-from-string (string-upcase (xsv name xe))) + (ListboxSelect + (let ((selection (parse-integer (tk-eval "~a curselection" (^path))))) + (setf (selection (selector self)) + (md-value (elt (^kids) selection)))))))))))
(defmodel listbox-item (tk-object) ((item-text :initarg :item-text :accessor item-text --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/15 05:15:37 1.9 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/16 02:52:22 1.10 @@ -38,7 +38,7 @@ ;; not recommended by Tcl doc (tcl-do-when-idle (get-callback 'tcl-idle-proc) 42) (tk-app-init *tki*) (tk-togl-init *tki*) - (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <<tracewrite>> -data {$n1 $op}}") + (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <<trace>> -data $op}")
(with-integrity () (setf *tkw* (make-instance root-class)) @@ -48,9 +48,7 @@ (tk-format `(:fini) "wm deiconify .") (tk-format-now "bind . <Escape> {destroy .}")
- ;; one or the other of... - (tcl-do-one-event-loop)#+either-or (Tk_MainLoop) - ) + (tcl-do-one-event-loop))
(defcallback main-window-proc :void ((client-data :int)(xe :pointer)) (declare (ignore client-data)) @@ -73,28 +71,11 @@ (defun tcl-do-one-event-loop () (loop while (plusp (tk-get-num-main-windows)) do (loop until (zerop (Tcl_DoOneEvent 2))) ;; 2== TCL_DONT_WAIT - (sleep *event-loop-delay*) + (sleep *event-loop-delay*) ;; give the IDE a few cycles finally ;;(tk-eval "exit") - (tcl-delete-interp *tki*) + (tcl-delete-interp *tki*) ;; probably unnecessary (setf *tki* nil)))
- - -(defmethod do-on-event (self event-type$ &rest args &aux (event-type (intern event-type$ :ctk))) - (assert (symbolp event-type)) - (trc nil "on event!!!" self event-type args) - (bif (ecb (gethash event-type (event-handlers self))) - (apply ecb self event-type args) - (progn - (trc "no event handlers for" self event-type (symbol-package event-type)) - (loop for k being the hash-keys of (event-handlers self) - do (trc "known key" k (symbol-package k)))))) - -(defmethod do-on-command (self &rest args) - (bif (ocb (on-command self)) - (apply ocb self args) - (trc "weird, no on-command value" self args))) - (defun test-window (root-class) "nails existing window as a convenience in iterative development" (declare (ignorable root-class)) --- /project/cells/cvsroot/Celtk/timer.lisp 2006/05/15 05:15:37 1.4 +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/05/16 02:52:22 1.5 @@ -52,7 +52,7 @@ (export '(repeat ^repeat)))
(defmodel timer () - ((id :cell nil :initarg :id :accessor id :initform (gentemp "AFTER") + ((id :cell nil :initarg :id :accessor id :initform :anon :documentation "A debugging aid") (tag :cell nil :initarg :tag :accessor tag :initform :anon :documentation "A debugging aid") @@ -99,8 +99,9 @@ (setf (id self) (set-timer self (^delay)))))))))))
(defun set-timer (self time) - (setf (gethash (id self) (dictionary *tkw*)) self) ;; redundant but fast - (tk-eval "after ~a {event generate . <<time-is-up>> -data ~a}" time (id self))) + (let ((lookup-id (gentemp "AFTER"))) + (setf (gethash lookup-id (dictionary *tkw*)) self) + (tk-eval "after ~a {event generate . <<time-is-up>> -data ~a}" time lookup-id)))
(defobserver timers ((self tk-object) new-value old-value) (dolist (k (set-difference old-value new-value)) --- /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/15 05:15:37 1.7 +++ /project/cells/cvsroot/Celtk/tk-interp.lisp 2006/05/16 02:52:22 1.8 @@ -160,8 +160,6 @@ (pathName :string) (related-tkwin :pointer))
- - ;;; --- Togl (Version 1.7 and above needed!) -----------------------------
@@ -253,39 +251,7 @@
(tcl-eval interp script))
-#+testing -(defun exec-button () - (tk-interp-init-ensure) - (let ((interp (Tcl_CreateInterp))) - (tk-app-init interp) - (togl_init interp) - #+works (progn - (eval-script interp "button .b1 -text Hello") - (eval-script interp "pack .b1")) - (eval-script interp "togl .t1 -height 100 -height 100 -ident t1") - ;;(eval-script interp "puts "Hello puts"") - ) - (Tk_MainLoop)) - -#+testing -(defun test-result () - (tk-interp-init-ensure) - (let ((*tki* (Tcl_CreateInterp))) - (tk-app-init *tki*) - #+wait (eval-script *tki* "font families") - #+ok (eval-script *tki* "tk scaling") - #+ok (progn - (eval-script *tki* "set xyz 42") - (eval-script *tki* "set xyz")) - ;;(trc "string result:" (tcl-get-string-result interp)) - (trc "tk-eval result:" (tk-eval "tk scaling")) - (trc "tk-eval-list result:" (tk-eval-list "font families")))) - -;;;(defun exec-main () -;;; (main "\0devtools\frgotk\psu-rc-gui.tcl")) -;;; -;;;#+test -;;;(exec-main) +
;;; Togl stuff
--- /project/cells/cvsroot/Celtk/widget.lisp 2006/05/15 05:15:37 1.5 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/05/16 02:52:22 1.6 @@ -22,6 +22,31 @@
(in-package :Celtk)
+;;; --- widget tkwin window glue ----------------------- + +(defun widget-to-tkwin (self) + (tk-name-to-window *tki* (path self) (tk-main-window *tki*))) + +(defun xwin-register (self) + (when (tkwin self) + (let ((xwin (tkwin-window (tkwin self)))) + (when (plusp xwin) + (setf (gethash xwin (xwins .tkw)) self) + xwin)))) + +(defun tkwin-widget (tkwin) + (gethash tkwin (tkwins *tkw*))) + +(defun xwin-widget (xwin) ;; assignment of xwin is deferred so...all this BS.. + (when (plusp xwin) + (or (gethash xwin (xwins *tkw*)) + (loop for self being the hash-values of (tkwins *tkw*) + using (hash-key tkwin) + unless (xwin self) ;; we woulda found it by now + do (when (eql xwin (xwin-register self)) + (return-from xwin-widget self)) + finally (trc "xwin-widget > no widget for xwin " xwin))))) + ;;; --- widget -----------------------------------------
(defmodel widget (family tk-object) @@ -35,10 +60,7 @@ (packing :reader packing :initarg :packing :initform nil) (gridding :reader gridding :initarg :gridding :initform nil) (enabled :reader enabled :initarg :enabled :initform t) - (event-handlers :reader event-handlers :initarg :event-handlers :initform nil) - (virtual-event-handlers :reader virtual-event-handlers :initarg :virtual-event-handlers :initform nil) - (needs-event-handler-p :reader needs-event-handler-p - :initform (c? (or (^event-handlers)(^virtual-event-handlers)))) + (event-handler :reader event-handler :initarg :event-handler :initform nil) (menus :reader menus :initarg :menus :initform nil :documentation "An assoc of an arbitrary key and the associated CLOS menu instances (not their tk ids)") (image-files :reader image-files :initarg :image-files :initform nil) @@ -48,26 +70,12 @@ (:default-initargs :id (gentemp "W")))
-(defobserver needs-event-handler-p () - (when new-value +(defobserver event-handler () + (when new-value ;; \\ work out how to unregister any old value (with-integrity (:client `(:post-make-tk ,self)) + (trc "creating event handler for" self) (tk-create-event-handler-ex self 'widget-event-handler -1)))) ;; // make this -1 more efficient
-(defun widget-to-tkwin (self) - (tk-name-to-window *tki* (path self) (tk-main-window *tki*))) - -(defcallback widget-event-handler :void ((client-data :int)(xe :pointer)) - (trc "bingo" (tk-event-type (xsv type xe))) - (case (tk-event-type (xsv type xe)) - (:virtualevent - (let* ((self (xwin-widget (xsv event-window xe))) - (name (read-from-string (string-upcase (xsv name xe)))) - (entry (assoc name (^virtual-event-handlers)))) - (TRC "widget-event-handler" self name) - (if entry - (funcall (second entry) self xe client-data) - (trc "no handler for" name self)))))) - (defun tk-create-event-handler-ex (widget callback-name &rest masks) (let ((self-tkwin (widget-to-tkwin widget))) (assert (plusp self-tkwin)) @@ -77,6 +85,13 @@ (get-callback callback-name) self-tkwin)))
+(defcallback widget-event-handler :void ((client-data :int)(xe :pointer)) + (let ((self (tkwin-widget client-data))) + (assert self () "widget-event-handler > no widget for tkwin ~a" client-data) + (bif (h (^event-handler)) + (funcall h self xe) + (trc "widget-event-handler > warning: no handler in instance requesting event handling" self)))) + (defclass commander () () (:default-initargs @@ -112,26 +127,6 @@ (tk-name-to-window *tki* (^path) (tk-main-window *tki*)))))) (setf (gethash tkwin (tkwins .tkw)) self)))
-(defun xwin-register (self) - (when (tkwin self) - (let ((xwin (tkwin-window (tkwin self)))) - (when (plusp xwin) - (setf (gethash xwin (xwins .tkw)) self) - xwin)))) - -(defun tkwin-widget (tkwin) - (gethash tkwin (tkwins *tkw*))) - -(defun xwin-widget (xwin) ;; assignment of xwin is deferred so...all this BS.. - (when (plusp xwin) - (or (gethash xwin (xwins *tkw*)) - (loop for self being the hash-values of (tkwins *tkw*) - using (hash-key tkwin) - unless (xwin self) ;; we woulda found it by now - do (when (eql xwin (xwin-register self)) - (return-from xwin-widget self)) - finally (trc "xwin-widget > no widget for xwin " xwin))))) - (defmethod make-tk-instance ((self widget)) (setf (gethash (^path) (dictionary .tkw)) self) (trc nil "mktki" self (^path)) @@ -139,6 +134,10 @@ (when (tk-class self) (tk-format-now "~(~a~) ~a ~{~(~a~) ~a~^ ~}" ;; call to this GF now integrity-wrapped by caller (tk-class self) (path self)(tk-configurations self))) + #+tryinafter (tkwin-register self))) + +(defmethod make-tk-instance :after ((self widget)) + (with-integrity (:client `(:post-make-tk ,self)) (tkwin-register self)))
(defmethod tk-configure ((self widget) option value)