[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Thu Jun 29 09:54:53 UTC 2006
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
More information about the Cells-cvs
mailing list