[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