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

Modified Files: Celtk.lisp frame.lisp togl.lisp widget.lisp Log Message:

--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/06/07 22:13:41 1.30 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/06/11 13:31:32 1.31 @@ -16,7 +16,7 @@

|#

-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.30 2006/06/07 22:13:41 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.31 2006/06/11 13:31:32 ktilton Exp $

(defpackage :celtk (:nicknames "CTK") @@ -135,7 +135,7 @@ (let ((yes '()) (no '("font"))) (declare (ignorable yes no)) - (when (and (or ;; (null yes) + (when t #+not (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$))) @@ -178,7 +178,7 @@ ; all this just to display "[". Unsolved is how we will ; send a text label with a string /containing/ the character #[ ; - (trc "tk-send-value" c (char-code c) (format nil ""\~3,'0o"" (char-code c))) + (trc nil "tk-send-value" c (char-code c) (format nil ""\~3,'0o"" (char-code c))) (format nil ""\~3,'0o"" (char-code c)))

(defmethod tk-send-value (other) --- /project/cells/cvsroot/Celtk/frame.lisp 2006/05/24 20:38:54 1.2 +++ /project/cells/cvsroot/Celtk/frame.lisp 2006/06/11 13:31:32 1.3 @@ -20,7 +20,7 @@

;--- group geometry -----------------------------------------

-(defmodel inline-mixin (composite-widget) +(defmodel inline-mixin (composite-widget widget) ((padx :initarg :padx :accessor padx :initform 0) (pady :initarg :pady :accessor pady :initform 0) (packing-side :initarg :packing-side :accessor packing-side :initform 'left) @@ -55,7 +55,7 @@

;--- f r a m e --------------------------------------------------

-(deftk frame (composite-widget) +(deftk frame (composite-widget widget) () (:tk-spec frame -borderwidth -cursor -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief --- /project/cells/cvsroot/Celtk/togl.lisp 2006/06/03 12:04:37 1.9 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/06/11 13:31:32 1.10 @@ -71,7 +71,7 @@ ;; Togl_DumpToEpsFile

(eval-when (compile load eval) - (export '(togl-swap-buffers togl-post-redisplay togl-ptr togl-reshape-func + (export '(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)))

@@ -148,6 +148,13 @@ :id (gentemp "TOGL") :ident (c? (^path))))

+(defmacro with-togl ((togl-form width-var height-var) &body body &aux (togl-ptr (gensym))) + `(let* ((,togl-ptr (togl-ptr ,togl-form)) + (*tki* (togl-interp ,togl-ptr)) + (,width-var (togl-width ,togl-ptr)) + (,height-var (togl-height ,togl-ptr))) + ,@body)) + (defmacro def-togl-callback (root (&optional (ptr-var 'togl-ptr)(self-var 'self)) &body preamble) (let ((register$ (format nil "TOGL-~a-FUNC" root)) (cb$ (format nil "TOGL-~a" root)) @@ -183,18 +190,6 @@ (with-integrity (:client `(:make-tk ,self)) (setf (gethash (^path) (dictionary .tkw)) self) (tk-format-now "togl ~a ~{~(~a~) ~a~^ ~}" - (path self)(tk-configurations self)))) ;; this leads to "togl <path> [-<config option> <value]*", in turn to togl_create - + (path self)(tk-configurations self)))) + ;; this leads to "togl <path> [-<config option> <value]*", in turn to togl_create

-;;; -;;;(DEFCFUN ("Togl_DestroyFunc" TOGL-DESTROY-FUNC) :VOID (CALLBACK :POINTER)) -;;;(defcallback togl-destroy :void ((togl-ptr :pointer)) -;;; (trc "togl-destroy ptr" togl-ptr (loop for k being the hash-keys of (tkwins *tkw*) -;;; collecting k)) -;;; (unless (c-stopped) -;;; (let ((self (or (gethash (pointer-address togl-ptr) (tkwins *tkw*)) (gethash (togl-ident togl-ptr) (dictionary *tkw*))))) -;;; -;;; (togl-destroy-using-class self)))) -;;;(DEFMETHOD TOGL-DESTROY-USING-CLASS :AROUND ((SELF TOGL)) -;;; (IF (CB-DESTROY SELF) (FUNCALL (CB-DESTROY SELF) SELF) (CALL-NEXT-METHOD))) -;;;(DEFMETHOD TOGL-DESTROY-USING-CLASS ((SELF TOGL))) \ No newline at end of file --- /project/cells/cvsroot/Celtk/widget.lisp 2006/06/07 22:13:41 1.13 +++ /project/cells/cvsroot/Celtk/widget.lisp 2006/06/11 13:31:32 1.14 @@ -47,10 +47,10 @@

(defmodel widget (family tk-object) ((path :accessor path :initarg :path - :initform (c? (trc nil "path calc" self (parent-path (fm-parent self)) (md-name self)) - (format nil "~(~a.~a~)" - (parent-path (fm-parent self)) - (md-name self)))) + :initform (c? (eko (nil "path" self (parent-path (fm-parent self))(md-name self)) + (format nil "~(~a.~a~)" + (parent-path (fm-parent self)) + (md-name self))))) (tkwin :cell nil :accessor tkwin :initform nil) (xwin :cell nil :accessor xwin :initform nil) (packing :reader packing :initarg :packing :initform nil) @@ -110,17 +110,12 @@ (tkwin-register self) (tk-create-event-handler-ex self 'widget-event-handler-callback -1)))

-;;;(defobserver relx () -;;; (when new-value -;;; (tk-format `(:grid ,self) -;;; "place ~a ~a -relx ~a -rely ~a" (if old-value "configure" "") -;;; (^path) new-value (^rely)))) - (defobserver px ((self widget)) - (when new-value - (tk-format `(:grid ,self) - "place ~a ~a -x ~a -y ~a" (if old-value "configure" "") - (^path) new-value (^py)))) + (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)))))

(defcallback widget-event-handler-callback :void ((client-data :pointer)(xe :pointer)) (let ((self (tkwin-widget client-data)))