[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Sun Jun 11 13:31:32 UTC 2006
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)))
+ , at 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)))
More information about the Cells-cvs
mailing list