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

Modified Files: Celtk.lisp composites.lisp demos.lisp run.lisp timer.lisp tk-object.lisp togl.lisp Log Message:

--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/07/06 22:10:39 1.34 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/09/05 18:43:22 1.35 @@ -16,7 +16,7 @@

|#

-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.34 2006/07/06 22:10:39 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.35 2006/09/05 18:43:22 ktilton Exp $

(defpackage :celtk (:nicknames "CTK") @@ -24,7 +24,7 @@ (:export #:right #:left #:<1> #:tk-event-type #:xsv #:name #:x #:y #:x-root #:y-root - #:title$ #:pop-up #:path #:parent-path #:^keyboard-modifiers #:keyboard-modifiers + #:title$ #:pop-up #:path #:parent-path #:^keyboard-modifiers #: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 --- /project/cells/cvsroot/Celtk/composites.lisp 2006/07/06 22:10:40 1.13 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/09/05 18:43:22 1.14 @@ -86,6 +86,8 @@ (defun app-idle (self) (setf (^app-time) (get-internal-real-time)))

+(export! keyboard-modifiers) + (defmd window (composite-widget) (title$ (c? (string-capitalize (class-name (class-of self))))) (dictionary (make-hash-table :test 'equalp)) @@ -102,6 +104,21 @@ on-key-down on-key-up)

+ + +(defmethod do-on-key-down :before (self &rest args &aux (keysym (car args))) + (trc nil "ctk::do-on-key-down window" keysym (keyboard-modifiers .tkw)) + (bwhen (mod (keysym-to-modifier keysym)) + (eko (nil "modifiers after adding" mod) + (pushnew mod (keyboard-modifiers .tkw))))) + +(defmethod do-on-key-up :before (self &rest args &aux (keysym (car args))) + (trc nil "ctk::do-on-key-up before" keysym (keyboard-modifiers .tkw)) + (bwhen (mod (keysym-to-modifier keysym)) + (eko (nil "modifiers after removing" mod) + (setf (keyboard-modifiers .tkw) + (delete mod (keyboard-modifiers .tkw)))))) + (defobserver initial-focus () (when new-value (tk-format '(:fini new-value) "focus ~a" (path new-value)))) --- /project/cells/cvsroot/Celtk/demos.lisp 2006/06/29 09:54:52 1.23 +++ /project/cells/cvsroot/Celtk/demos.lisp 2006/09/05 18:43:22 1.24 @@ -19,6 +19,35 @@ (in-package :celtk-user)

+(defmodel my-test (window) + ((my-mode :accessor my-mode :initform (c? (evenp (selection (fm! :my-selector)))))) + (:default-initargs + :id :my-test-id + :kids (c? (the-kids + (mk-stack ("stack" :packing (c?pack-self "-side bottom") :relief 'ridge) + (mk-entry :id :my-entry + :md-value (c-in "abc")) + (mk-row ( "row" #| :packing (c?pack-self "-side bottom") |# :relief 'ridge) + (mk-label :text (c? (format nil "selection: ~a" (selection (fm^ :my-selector))))) + (mk-label :text "Labeltext") + (mk-button-ex ("Reset" (setf (selection (fm^ :my-selector)) 1))) + (mk-stack ((c? (format nil "current selection: ~a" (^selection))) :id :my-selector :selection (c-in 1) :relief 'ridge) + (mk-radiobutton-ex ("selection 1" 1)) + (mk-radiobutton-ex ("selection 2" 2)) + (mk-radiobutton-ex ("selection 3" 3)) + (mk-radiobutton-ex ("selection 4" 4))) + (mk-label :text (c? (format nil "selection: ~a" (selection (fm^ :my-selector))))) + )))))) + +(defobserver my-mode ((self my-test) new-value old-value old-value-bound-p) + (format t "~% mode changed from ~a to ~a" old-value new-value)) + +(defun ctk::franks-test () + (run-window 'my-test)) + +#+test +(ctk::franks-test) + (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package (test-window ;;'place-test --- /project/cells/cvsroot/Celtk/run.lisp 2006/07/06 22:10:40 1.19 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/09/05 18:43:22 1.20 @@ -53,7 +53,7 @@ :fm-parent *parent* window-initargs)))) ))) - + (assert (tkwin *tkw*))

(tk-format `(:fini) "wm deiconify .") @@ -89,29 +89,32 @@

(defmethod widget-event-handle ((self window) xe) (let ((*tkw* self)) - (TRC nil "main window event" *tkw* (xevent-type xe)) + (TRC nil "main window event" self *tkw* (xevent-type xe)) (flet ((give-to-window () (bwhen (eh (event-handler *tkw*)) (funcall eh *tkw* xe)))) (case (xevent-type xe) ((:MotionNotify :buttonpress) #+shhh (call-dump-event client-data xe)) + (:destroyNotify (let ((*windows-destroyed* (cons *tkw* *windows-destroyed*))) (ensure-destruction *tkw*))) + (:virtualevent (bwhen (n$ (xsv name xe)) (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 (trc "going after keysym") + (keypress (break "this works??: 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*))) (trc "unhandled pressed keysym" keysym)))) - (keyrelease (let ((keysym (tcl-get-string (xsv user-data xe)))) + (keyrelease (break "this works??: going after keysym") + (let ((keysym (tcl-get-string (xsv user-data xe)))) (bIf (mod (keysym-to-modifier keysym)) (eko ("modifiers now") (setf (keyboard-modifiers *tkw*) @@ -123,14 +126,15 @@ (window-destroyed (ensure-destruction *tkw*))

- (otherwise (give-to-window))))) + (otherwise + (give-to-window))))) (otherwise (give-to-window))) 0)))

;; Our own event loop ! - Use this if it is desirable to do something ;; else between events

-(defparameter *event-loop-delay* 0.08 "Minimum delay [s] in event loop not to lock out IDE (ACL anyway)") +(defparameter *event-loop-delay* 0.08 "Minimum delay [s] in event loop not to lock out IDE (ACL anyway)")

(defun tcl-do-one-event-loop () (loop while (plusp (tk-get-num-main-windows)) --- /project/cells/cvsroot/Celtk/timer.lisp 2006/09/03 13:39:56 1.11 +++ /project/cells/cvsroot/Celtk/timer.lisp 2006/09/05 18:43:22 1.12 @@ -93,6 +93,9 @@ (with-integrity (:client `(:fini ,self)) ;; just guessing as to when, not sure it matters (set-timer self (^delay))))))))))

+(defmethod not-to-be :before ((self timer)) + (setf (state self) :off)) + (defobserver state ((self timer)) (unless (eq new-value :on) (cancel-timer self))) --- /project/cells/cvsroot/Celtk/tk-object.lisp 2006/09/03 13:39:56 1.9 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2006/09/05 18:43:22 1.10 @@ -25,20 +25,15 @@ ((.md-name :cell nil :initform (gentemp "TK") :initarg :id) (tk-class :cell nil :initform nil :initarg :tk-class :reader tk-class)

- (timers :initarg :timers :accessor timers :initform nil) + (timers :owning t :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 - :documentation "Long story. Tcl C API sucks for keypress events. This gets dispatched + :documentation "Long story. Tcl C API weak 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"))

-(defmethod not-to-be :before ((self tk-object)) - (loop for timer in (^timers) do - (setf (state timer) :off) - (not-to-be timer))) - (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self))

--- /project/cells/cvsroot/Celtk/togl.lisp 2006/09/03 13:39:56 1.19 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/09/05 18:43:22 1.20 @@ -185,8 +185,8 @@

(def-togl-callback create () (trc "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr ) - ;;#+cl-ftgl (setf cl-ftgl::*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready - ;;(ogl::kt-opengl-reset) + #+cl-ftgl (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready + #+kt-opengl (kt-opengl:kt-opengl-reset) (setf (togl-ptr self) togl-ptr) (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))