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

Modified Files: CELTK.lpr Celtk.lisp button.lisp composites.lisp demos.lisp run.lisp tk-object.lisp togl.lisp widget.lisp Log Message:

--- /project/cells/cvsroot/Celtk/CELTK.lpr 2006/06/07 22:13:41 1.16 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2006/06/29 09:54:52 1.17 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*-

(in-package :cg-user)

@@ -35,9 +35,7 @@ :projects (list (make-instance 'project-module :name "..\cells\cells") (make-instance 'project-module :name - "C:\1-devtools\cffi\cffi") - (make-instance 'project-module :name - "..\Cells\gui-geometry\gui-geometry")) + "C:\1-devtools\cffi\cffi")) :libraries nil :distributed-files nil :internally-loaded-files nil --- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/06/11 13:31:32 1.31 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/06/29 09:54:52 1.32 @@ -16,7 +16,7 @@

|#

-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.31 2006/06/11 13:31:32 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.32 2006/06/29 09:54:52 ktilton Exp $

(defpackage :celtk (:nicknames "CTK") @@ -52,6 +52,9 @@

(in-package :Celtk)

+#+(and allegrocl ide (not runtime-system)) +(ide::defdefiner defcallback defun) + (defvar *tki* nil) (defparameter *windows-being-destroyed* nil) (defparameter *windows-destroyed* nil) @@ -135,7 +138,7 @@ (let ((yes '()) (no '("font"))) (declare (ignorable yes no)) - (when t #+not (and (or ;; (null yes) + (when #+not t (and (or ;; (null yes) (find-if (lambda (s) (search s tk$)) yes)) (not (find-if (lambda (s) (search s tk$)) no))) (format t "~&tk> ~a~%" tk$))) --- /project/cells/cvsroot/Celtk/button.lisp 2006/05/24 20:38:54 1.4 +++ /project/cells/cvsroot/Celtk/button.lisp 2006/06/29 09:54:52 1.5 @@ -18,10 +18,6 @@

(in-package :Celtk)

-(defcallback foo :int ((a :int) (b :int)) - (declare (ignore b)) - a) - ;--- button ----------------------------------------------

(deftk button (commander widget) --- /project/cells/cvsroot/Celtk/composites.lisp 2006/06/03 12:04:37 1.10 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/06/29 09:54:52 1.11 @@ -70,7 +70,7 @@ ((kids-packing :initarg :kids-packing :accessor kids-packing :initform nil)))

(eval-when (compile load eval) - (export '(title$ active))) + (export '(title$ active .time)))

(defvar *app*)

@@ -79,28 +79,28 @@ :initarg :app-time :accessor app-time)))

+(define-symbol-macro .time (app-time *app*)) + (defmethod path ((self application)) nil)

(defun app-idle (self) - (setf (^app-time) (now))) + (setf (^app-time) (get-internal-real-time)))

-(defmodel window (composite-widget) - ((title$ :initarg :title$ :accessor title$ - :initform (c? (string-capitalize (class-name (class-of self))))) - (dictionary :initarg :dictionary :initform (make-hash-table :test 'equalp) :accessor dictionary) - (tkwins :initform (make-hash-table) :reader tkwins) - (xwins :initform (make-hash-table) :reader xwins) - (keyboard-modifiers :initarg :keyboard-modifiers :initform (c-in nil) :accessor keyboard-modifiers) - (callbacks :initarg :callbacks :accessor callbacks - :initform (make-hash-table :test #'eq)) - (edit-style :initarg :edit-style :accessor edit-style :initform (c-in nil)) - (tk-scaling :initarg :tk-scaling :accessor tk-scaling - :initform (c? 1.3 #+tki (read-from-string (tk-eval "tk scaling")))) - (tkfonts-to-load :initarg :tkfonts-to-load :accessor tkfonts-to-load :initform nil) - (tkfont-sizes-to-load :initarg :tkfont-sizes-to-load :accessor tkfont-sizes-to-load :initform nil) - (tkfont-info :initarg :tkfont-info :accessor tkfont-info - :initform (tkfont-info-loader)) - (initial-focus :initarg :initial-focus :accessor initial-focus :initform nil))) +(defmd window (composite-widget) + (title$ (c? (string-capitalize (class-name (class-of self))))) + (dictionary (make-hash-table :test 'equalp)) + (tkwins (make-hash-table)) + (xwins (make-hash-table)) + (keyboard-modifiers (c-in nil)) + (callbacks (make-hash-table :test #'eq)) + (edit-style (c-in nil)) + (tk-scaling (c? 1.3 #+tki (read-from-string (tk-eval "tk scaling")))) + tkfonts-to-load + tkfont-sizes-to-load + (tkfont-info (tkfont-info-loader)) + initial-focus + on-key-down + on-key-up)

(defobserver initial-focus () (when new-value --- /project/cells/cvsroot/Celtk/demos.lisp 2006/06/07 22:13:41 1.22 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/06/29 09:54:52 1.23 @@ -35,7 +35,7 @@ (:default-initargs :kids (c? (the-kids (mk-label :text "hi, Mom" - :px 100 + :parent-x 100 :py 20)))))

(defmodel one-button-window (window) --- /project/cells/cvsroot/Celtk/run.lisp 2006/06/07 22:13:41 1.16 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/06/29 09:54:52 1.17 @@ -23,10 +23,11 @@ (eval-when (compile load eval) (export '(tk-scaling run-window test-window)))

-(defun run-window (root-class) +(defun run-window (root-class &optional (resetp t)) (declare (ignorable root-class)) (setf *tkw* nil) - (cells-reset 'tk-user-queue-handler) + (when resetp + (cells-reset 'tk-user-queue-handler)) (tk-interp-init-ensure)

(setf *tki* (Tcl_CreateInterp)) @@ -34,7 +35,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) (null-pointer) (null-pointer)) + + ;; these next exist because of limitations in the Tcl API. eg, the keypress event does not + ;; include enough info to extract the keysym directly, and the function to extract the + ;; keysym is not exposed. The keysym, btw, is the portable representation of key events. + (tcl-create-command *tki* "do-key-down" (get-callback 'do-on-key-down) (null-pointer) (null-pointer)) (tcl-create-command *tki* "do-key-up" (get-callback 'do-on-key-up) (null-pointer) (null-pointer))

@@ -46,13 +53,15 @@ :fm-parent *parent*)))))))

(assert (tkwin *tkw*)) - - (tk-create-event-handler-ex *tkw* 'main-window-proc -1)

(tk-format `(:fini) "wm deiconify .") (tk-format-now "bind . <Escape> {destroy .}") + ; + ; see above for why we are converting key x-events to application key virtual events: + ; (tk-format-now "bind . <KeyPress> {do-key-down %W %K}") (tk-format-now "bind . <KeyRelease> {do-key-up %W %K}") + (tcl-do-one-event-loop))

(defun ensure-destruction (w) @@ -76,10 +85,9 @@ (defun keysym-to-modifier (keysym) (gethash keysym *keyboard-modifiers*))

-(defcallback main-window-proc :void ((client-data :pointer)(xe :pointer)) - (let ((*tkw* (tkwin-widget client-data))) - (assert (typep *tkw* 'window)) - (TRC nil "main window event" (xevent-type xe)) +(defmethod widget-event-handle ((self window) xe) + (let ((*tkw* self)) + (TRC nil "main window event" *tkw* (xevent-type xe)) (flet ((give-to-window () (bwhen (eh (event-handler *tkw*)) (funcall eh *tkw* xe)))) @@ -94,7 +102,9 @@ (trc nil "main-window-proc :" n$ (unless (null-pointer-p (xsv user-data xe)) (tcl-get-string (xsv user-data xe)))) (case (read-from-string (string-upcase n$)) - (keypress (let ((keysym (tcl-get-string (xsv user-data xe)))) + (keypress (trc "going after keysym") + (let ((keysym (tcl-get-string (xsv user-data xe)))) + (trc "keypress keysym!!!!" (tcl-get-string (xsv user-data xe))) (bIf (mod (keysym-to-modifier keysym)) (eko ("modifiers now") (pushnew mod (keyboard-modifiers *tkw*))) @@ -122,8 +132,8 @@

(defun tcl-do-one-event-loop () (loop while (plusp (tk-get-num-main-windows)) - do (loop until (zerop (Tcl_DoOneEvent 2)) - do (app-idle *app*)) ;; 2== TCL_DONT_WAIT + do (loop until (zerop (Tcl_DoOneEvent 2)) ;; 2== TCL_DONT_WAIT + do (app-idle *app*)) (app-idle *app*) (sleep *event-loop-delay*) ;; give the IDE a few cycles finally @@ -133,7 +143,7 @@

(defmethod window-idle ((self window)))

-(defun test-window (root-class) +(defun test-window (root-class &optional (resetp t)) "nails existing window as a convenience in iterative development" (declare (ignorable root-class))

@@ -144,7 +154,7 @@ (force-output *tkw*) (setf *tkw* nil))

- (run-window root-class)) + (run-window root-class resetp))

;;; --- commands -----------------------------------------------------------------

@@ -163,7 +173,9 @@ (args (loop for argn upfrom 1 below argc collecting (mem-aref argv :string argn)))) (bif (self (gethash (car args) (dictionary *tkw*))) - (apply ',do-on-name self (rest args)) + (progn + (trc nil "defcommand > " ',^on-name self (cdr args)) + (apply ',do-on-name self (rest args))) (progn (break ",do-on-name> Target widget ~a does not exist" (car args)) #+anyvalue? (tcl-set-result interp @@ -172,6 +184,9 @@ 1)))))))

(defcommand command) -(defcommand key-up) +; +; see notes elsewhere for why Tcl API deficiencies require augmented key handling via app virtual events +; (defcommand key-down) +(defcommand key-up)

--- /project/cells/cvsroot/Celtk/tk-object.lisp 2006/06/07 22:13:41 1.6 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2006/06/29 09:54:52 1.7 @@ -27,7 +27,9 @@

(timers :initarg :timers :accessor timers :initform nil) (on-command :initarg :on-command :accessor on-command :initform nil) - (on-key-down :initarg :on-key-down :accessor on-key-down :initform nil) + (on-key-down :initarg :on-key-down :accessor on-key-down :initform nil + :documentation "Long story. Tcl C API sucks for keypress events. This gets dispatched +eventually thanks to DEFCOMMAND") (on-key-up :initarg :on-key-up :accessor on-key-up :initform nil) (user-errors :initarg :user-errors :accessor user-errors :initform nil)) (:documentation "Root class for widgets and (canvas) items")) --- /project/cells/cvsroot/Celtk/togl.lisp 2006/06/11 13:31:32 1.10 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/06/29 09:54:52 1.11 @@ -71,7 +71,7 @@ ;; Togl_DumpToEpsFile

(eval-when (compile load eval) - (export '(with-togl togl-interp togl-swap-buffers togl-post-redisplay togl-ptr togl-reshape-func + (export '(togl with-togl togl-interp togl-swap-buffers togl-post-redisplay togl-ptr togl-reshape-func togl togl-timer-using-class togl-post-redisplay togl-reshape-using-class togl-display-using-class togl-width togl-height togl-create-using-class)))

--- /project/cells/cvsroot/Celtk/widget.lisp 2006/06/11 13:31:32 1.14 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/06/29 09:54:52 1.15 @@ -55,8 +55,8 @@ (xwin :cell nil :accessor xwin :initform nil) (packing :reader packing :initarg :packing :initform nil) (gridding :reader gridding :initarg :gridding :initform nil) - (px :reader px :initarg :px :initform nil) - (py :reader py :initarg :py :initform nil) + (parent-x :reader parent-x :initarg :parent-x :initform nil) + (parent-y :reader parent-y :initarg :parent-y :initform nil) (relx :reader relx :initarg :relx :initform nil) (rely :reader rely :initarg :rely :initform nil) (enabled :reader enabled :initarg :enabled :initform t) @@ -69,7 +69,7 @@ (:default-initargs :id (gentemp "W") :event-handler nil #+debug (lambda (self xe) - (TRC "widget-event-handler" self (tk-event-type (xsv type xe)))))) + (TRC "debug event handler" self (tk-event-type (xsv type xe))))))

(eval-when (compile load eval) (export '())) @@ -110,20 +110,21 @@ (tkwin-register self) (tk-create-event-handler-ex self 'widget-event-handler-callback -1)))

-(defobserver px ((self widget)) +(defobserver parent-x ((self widget)) (unless (typep self 'window) (when new-value (tk-format `(:grid ,self) ;; placing is like grid for this sort "place ~a ~a -x ~a -y ~a" (if old-value "configure" "") - (^path) new-value (^py))))) + (^path) new-value (^parent-y)))))

(defcallback widget-event-handler-callback :void ((client-data :pointer)(xe :pointer)) - (let ((self (tkwin-widget client-data))) - (assert self () "widget-event-handler > no widget for tkwin ~a" client-data) - (widget-event-handle self xe))) + (bif (self (tkwin-widget client-data)) + (widget-event-handle self xe) + ;; sometimes I hit the next branch restarting after crash.... + (trc "widget-event-handler > no widget for tkwin ~a" client-data)))

-(defmethod widget-event-handle ((self widget) xe) - (bif (h (^event-handler)) +(defmethod widget-event-handle ((self widget) xe) ;; override for class-specific handling + (bif (h (^event-handler)) ;; support instance-specific handlers (funcall h self xe) #+shhh (case (xevent-type xe) (:buttonpress