[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Tue May 16 02:52:22 UTC 2006
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)
More information about the Cells-cvs
mailing list