[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Tue Sep 5 18:43:23 UTC 2006
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))
More information about the Cells-cvs
mailing list