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

Modified Files: demos.lisp entry.lisp menu.lisp multichoice.lisp run.lisp timer.lisp tk-events.lisp widget.lisp Log Message: create command replacing event generate

--- /project/cells/cvsroot/Celtk/demos.lisp 2006/05/16 21:17:15 1.16 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/05/17 00:40:55 1.17 @@ -25,11 +25,11 @@

(defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window - ;; true tester: 'one-button-window + ;;'one-button-window ;; Not so good: 'ltktest-cells-inside ;; 'menu-button-test - ;; 'spinbox-test - 'lotsa-widgets + 'spinbox-test + ;; 'lotsa-widgets ;; Now in Gears project 'gears-demo ))

@@ -40,6 +40,11 @@ (mk-frame-stack :packing (c?pack-self) :kids (c? (the-kids + (mk-menubar + :kids (c? (the-kids + (mk-menu-entry-cascade-ex (:label "File") + (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) + (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed")))))) (make-instance 'entry :id :entree :fm-parent *parent* @@ -48,70 +53,19 @@ :fm-parent *parent* :text "read" :on-command (lambda (self) - (trc "entry reads" (ctk::tk-eval-var (path (fm^ :entree))))))))))))) - -#+save -(defmodel one-button-window (window) - () - (:default-initargs - :on-event (lambda (self &rest event-args) - (trc "we got events" self event-args)) - :kids (c? (the-kids - (mk-menubar - :kids (c? (the-kids - (mk-menu-entry-cascade-ex (:label "File") - (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed")) - (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed")))))) - (mk-frame-stack - :packing (c?pack-self) - :kids (c? (the-kids - - ;;; (mk-scrolled-list - ;;; :id :spinpkg-sym-list - ;;; :list-height 6 - ;;; :list-item-keys (c? (loop for sym being the symbols in (find-package "CELTK") - ;;; for n below 5 - ;;; counting sym into symct - ;;; collecting sym into syms - ;;; finally (trc "syms found !!!" symct) - ;;; (return syms))) - ;;; :list-item-factory (lambda (sym) - ;;; (trc "make list item" sym *parent*) - ;;; (make-instance 'listbox-item - ;;; :fm-parent *parent* - ;;; :md-value sym - ;;; :item-text (down$ (symbol-name sym))))) - (mk-text-widget - :id :my-text - :md-value (c?n "hello, world") - :height 3 - :width 25) - (make-instance 'button - :fm-parent *parent* - :text "<<kenny>>" - :on-command (lambda (self) - (trc "button pushed!!!" self))) - ;;; (make-instance 'button - ;;; :fm-parent *parent* - ;;; :text "time now?" - ;;; :on-command (c? (lambda (self) - ;;; (trc "we got callbacks" self)))) + (trc "entry reads" (ctk::tk-eval-var (path (fm^ :entree)))))) (make-instance 'scale :fm-parent *parent* :tk-label "Boots" :on-command (c? (lambda (self value) - (trc "we got scale callbacks" self value)))) + (trc "we got scale callbacks" self (parse-integer value))))) (mk-spinbox :id :spin-pkg :md-value (c-in "cells") ;;(cells::c?n "cells") :tk-values (mapcar 'down$ (sort (mapcar 'package-name (list-all-packages)) - 'string>))) - (make-instance 'entry - :fm-parent *parent* - :md-value (c-in "Boots")) - ))))))) + 'string>))))))))))

(defmodel spinbox-test (window) () @@ -142,7 +96,8 @@ (make-instance 'listbox-item :fm-parent *parent* :md-value sym - :item-text (down$ (symbol-name sym)))))))))) + :item-text (down$ (symbol-name sym))))) + (mk-label :text (c? (selection (fm^ :spinpkg-sym-list)))))))))

(defmodel menu-button-test (window) --- /project/cells/cvsroot/Celtk/entry.lisp 2006/05/16 02:52:22 1.7 +++ /project/cells/cvsroot/Celtk/entry.lisp 2006/05/17 00:40:55 1.8 @@ -65,8 +65,7 @@

(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 --- /project/cells/cvsroot/Celtk/menu.lisp 2006/05/16 21:17:15 1.14 +++ /project/cells/cvsroot/Celtk/menu.lisp 2006/05/17 00:40:55 1.15 @@ -172,7 +172,7 @@ () (:tk-spec command -command) (:default-initargs - :command (c? (format nil "event generate . <<do-menu-command>> -data ~a" (path-idx self))))) + :command (c? (format nil "do-on-command ~a" (path-idx self)))))

(defmacro mk-menu-entry-command-ex ((&rest menu-command-initargs) lbl callback-body) `(mk-menu-entry-command --- /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/16 21:17:15 1.7 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2006/05/17 00:40:55 1.8 @@ -44,10 +44,9 @@ :tk-variable nil ;;(c? (^path)) :xscrollcommand (c-in nil) :yscrollcommand (c-in nil) - :command (c? (format nil "event generate ~a <<do-on-command>> -data" (^path))) :on-command (lambda (self value) ;; (trc "hi scale" self value) - (setf (^md-value) value)))) + (setf (^md-value) (parse-integer value)))))

(defmethod make-tk-instance :after ((self scale)) "Still necessary?" @@ -116,7 +115,7 @@ :id (gentemp "SPN") :textVariable (c? (^path)) :xscrollcommand (c-in nil) - :command (c? (format nil "event generate ~a <<do-on-command>> -data %s" (^path))) + :command (c? (format nil "do-on-command ~a %s" (^path))) :on-command (c? (lambda (self text) (eko ("variable mirror command fired !!!!!!!" text) (setf (^md-value) text)))))) --- /project/cells/cvsroot/Celtk/run.lisp 2006/05/16 02:52:22 1.10 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/05/17 00:40:55 1.11 @@ -39,12 +39,13 @@ (tk-app-init *tki*) (tk-togl-init *tki*) (tk-format-now "proc TraceOP {n1 n2 op} {event generate $n1 <<trace>> -data $op}") + (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) 42 0)

(with-integrity () (setf *tkw* (make-instance root-class))

(tk-create-event-handler-ex *tkw* 'main-window-proc :virtualEventMask)) - + (tk-format `(:fini) "wm deiconify .") (tk-format-now "bind . <Escape> {destroy .}")

@@ -55,9 +56,6 @@ (when (eq (xevent-type xe) :virtualevent) (bwhen (n$ (xsv name xe)) (case (read-from-string (string-upcase n$)) - (do-menu-command (let ((self (gethash (tcl-get-string (xsv user-data xe)) (dictionary *tkw*)))) - (bwhen (c (^on-command)) - (funcall c self)))) (time-is-up (let ((self (gethash (tcl-get-string (xsv user-data xe)) (dictionary *tkw*)))) (bwhen (c (^on-command)) (funcall c self)))) --- /project/cells/cvsroot/Celtk/timer.lisp 2006/05/16 02:52:22 1.5 +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/05/17 00:40:55 1.6 @@ -52,7 +52,7 @@ (export '(repeat ^repeat)))

(defmodel timer () - ((id :cell nil :initarg :id :accessor id :initform :anon + ((id :cell nil :initarg :id :accessor id :initform (gentemp "AFTER") :documentation "A debugging aid") (tag :cell nil :initarg :tag :accessor tag :initform :anon :documentation "A debugging aid") @@ -99,9 +99,8 @@ (setf (id self) (set-timer self (^delay)))))))))))

(defun set-timer (self time) - (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))) + (setf (gethash (id self) (dictionary *tkw*)) self) + (tk-eval "after ~a {do-on-command ~a}" time (id self)))

(defobserver timers ((self tk-object) new-value old-value) (dolist (k (set-difference old-value new-value)) --- /project/cells/cvsroot/Celtk/tk-events.lisp 2006/05/15 05:15:37 1.2 +++ /project/cells/cvsroot/Celtk/tk-events.lisp 2006/05/17 00:40:55 1.3 @@ -8,6 +8,18 @@ (tcl-idle-proc :pointer) (client-data :int))

+(defcfun ("Tcl_CreateCommand" tcl-create-command) :pointer + (interp :pointer) + (cmdName :string) + (proc :pointer) + (client-data :int) + (delete-proc :pointer)) + +(defcfun ("Tcl_SetResult" tcl-set-result) :void + (interp :pointer) + (result :string) + (free-proc :pointer)) + (defcfun ("Tcl_GetString" tcl-get-string) :string (tcl-obj :pointer))

--- /project/cells/cvsroot/Celtk/widget.lisp 2006/05/16 21:17:15 1.7 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/05/17 00:40:55 1.8 @@ -95,24 +95,21 @@ (defclass commander () () (:default-initargs - :command (c? (format nil "event generate ~a <<do-on-command>>" (^path))))) + :command (c? (format nil "do-on-command ~a" (^path)))))

-(defcallback commander-event-proc :void ((client-data :int)(xe :pointer)) +(defcallback do-on-command :int ((client-data :int)(interp :pointer)(argc :int)(argv :pointer)) (declare (ignore client-data)) - (when (eq (xevent-type xe) :virtualevent) - (bwhen (n$ (xsv name xe)) - (case (read-from-string (string-upcase n$)) - (do-on-command (let ((self (xwin-widget (xsv event-window xe)))) - (bwhen (c (^on-command)) - (let ((d (xsv user-data xe))) - (if (plusp d) - (funcall c self (read-from-string (tcl-get-string d))) - (funcall c self)))))) - (otherwise (trc "commander sees unknown" n$)))))) - -(defmethod make-tk-instance :after ((self commander)) - (with-integrity (:client `(:post-make-tk ,self)) - (tk-create-event-handler-ex self 'commander-event-proc :virtualEventMask))) + (destructuring-bind (path &rest args) + (loop for argn upfrom 1 below argc + collecting (mem-aref argv :string argn)) + (bif (self (gethash path (dictionary *tkw*))) + (bIf (cmd (^on-command)) + (progn (apply cmd self args) + 0) + (progn (tcl-set-result interp (format nil "do-on-command> Target widget ~a has no on-command to run" path) 0) + 1)) + (progn (tcl-set-result interp (format nil "do-on-command> Target widget ~a does not exist" path) 0) + 1))))

(defun widget-menu (self key) (or (find key (^menus) :key 'md-name)