[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Wed May 17 00:40:55 UTC 2006
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)
More information about the Cells-cvs
mailing list