[cells-cvs] CVS Celtk
ktilton
ktilton at common-lisp.net
Mon Oct 2 02:56:01 UTC 2006
Update of /project/cells/cvsroot/Celtk
In directory clnet:/tmp/cvs-serv27482
Modified Files:
Celtk.lisp composites.lisp run.lisp togl.lisp widget.lisp
Log Message:
--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/09/05 18:43:22 1.35
+++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/10/02 02:56:01 1.36
@@ -16,7 +16,7 @@
|#
-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.35 2006/09/05 18:43:22 ktilton Exp $
+;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.36 2006/10/02 02:56:01 ktilton Exp $
(defpackage :celtk
(:nicknames "CTK")
@@ -103,31 +103,6 @@
(trc nil "!!! --- tk-user-queue-handler dispatching" defer-info)
(funcall task)))
-(defun replace-char (txt char with)
- (let ((pos (search char txt)))
- (loop
- while pos
- do
- (progn
- ;;(dbg "txt: ~a -> " txt)
- (setf txt (concatenate 'string (subseq txt 0 pos) with (subseq txt (1+ pos))))
- ;;(dbg " ~a~&" txt)
- (setf pos (search char txt :start2 (+ pos (length with)))))))
- txt)
-
-(defun tkescape (txt)
- (setf txt (format nil "~a" txt))
- (replace-char
- (replace-char
- (replace-char
- (replace-char
- (replace-char
- txt "\\" "\\\\")
- "$" "\\$")
- "[" "\\[")
- "]" "\\]")
- "\"" "\\\""))
-
(defun tk-format-now (fmt$ &rest fmt-args)
(unless (find *tkw* *windows-destroyed*)
(let* ((*print-circle* nil)
--- /project/cells/cvsroot/Celtk/composites.lisp 2006/09/29 16:08:31 1.18
+++ /project/cells/cvsroot/Celtk/composites.lisp 2006/10/02 02:56:01 1.19
@@ -32,7 +32,7 @@
;;; --- decoration -------------------------------------------
(defmd decoration-mixin ()
- (decoration (c-in :normal)))
+ (decoration (c-in nil)))
;;; --- toplevel ---------------------------------------------
@@ -113,6 +113,9 @@
on-key-down
on-key-up)
+(defmethod make-tk-instance ((self window))
+ (setf (gethash (^path) (dictionary .tkw)) self))
+
(defun screen-width ()
(let ((*tkw* *tkw*))
(tk-format-now "winfo screenwidth .")))
@@ -133,6 +136,7 @@
(tk-format '(:pre-make-tk self) "wm overrideredirect . yes")
)
+
(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))
@@ -148,6 +152,7 @@
;;; Helper function that actually executes decoration change
(defun %%do-decoration (widget decoration)
+ (break "hunh?")
(let ((path (path widget)))
(ecase decoration
(:none (progn
--- /project/cells/cvsroot/Celtk/run.lisp 2006/09/05 18:43:22 1.20
+++ /project/cells/cvsroot/Celtk/run.lisp 2006/10/02 02:56:01 1.21
@@ -18,6 +18,8 @@
(in-package :Celtk)
+
+
;;; --- running a Celtk (window class, actually) --------------------------------------
(eval-now!
@@ -66,6 +68,8 @@
(tcl-do-one-event-loop))
+
+
(defun ensure-destruction (w)
(TRC nil "ensure-destruction entry" W)
(unless (find w *windows-being-destroyed*)
--- /project/cells/cvsroot/Celtk/togl.lisp 2006/09/05 18:43:22 1.20
+++ /project/cells/cvsroot/Celtk/togl.lisp 2006/10/02 02:56:01 1.21
@@ -90,8 +90,12 @@
(togl-timer-func (callback togl-timer)) ;; probably want to make this optional
)
+(export! togl-ptr-set ^togl-ptr-set)
+
(deftk togl (widget)
- ((togl-ptr :cell nil :initform nil :initarg :togl-ptr :accessor togl-ptr)
+ ((togl-ptr :cell nil :initform nil :initarg :togl-ptr :accessor togl-ptr)
+ (togl-ptr-set :initform (c-in nil) :initarg :togl-ptr-set :accessor togl-ptr-set
+ :documentation "very complicated, don't ask (togl-ptr cannot wait on ufb processing)")
(cb-create :initform nil :initarg :cb-create :reader cb-create)
(cb-display :initform nil :initarg :cb-display :reader cb-display)
(cb-reshape :initform nil :initarg :cb-reshape :reader cb-reshape)
@@ -150,6 +154,11 @@
:id (gentemp "TOGL")
:ident (c? (^path))))
+(export! togl-redisp)
+(defun togl-redisp (togl)
+ (when (togl-ptr togl)
+ (togl-post-redisplay (togl-ptr togl))))
+
(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))
@@ -184,10 +193,11 @@
(defmethod ,(intern uc$) ((self togl))))))
(def-togl-callback create ()
- (trc "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr )
+ (trc "___________________ TOGL SET UP _________________________________________" 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
#+kt-opengl (kt-opengl:kt-opengl-reset)
- (setf (togl-ptr self) togl-ptr)
+ (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred
+ (setf (togl-ptr-set self) togl-ptr) ;; this gets deferred, which is OK
(setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))
(def-togl-callback display ())
@@ -198,7 +208,6 @@
(defmethod make-tk-instance ((self togl))
(with-integrity (:client `(:make-tk ,self))
(setf (gethash (^path) (dictionary .tkw)) self)
+ (trc "making togl!!!!!!!!!!!!" (path self)(tk-configurations 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
-
--- /project/cells/cvsroot/Celtk/widget.lisp 2006/08/21 04:30:23 1.17
+++ /project/cells/cvsroot/Celtk/widget.lisp 2006/10/02 02:56:01 1.18
@@ -87,8 +87,6 @@
(get-callback callback-name)
self-tkwin)))
-
-
(defun widget-menu (self key)
(or (find key (^menus) :key 'md-name)
(break "The only menus I see are~{ ~a,~} not requested ~a" (mapcar 'md-name (^menus)) key)))
@@ -106,10 +104,9 @@
(setf (gethash (^path) (dictionary .tkw)) self)
(trc nil "mktki" self (^path))
(with-integrity (:client `(:make-tk ,self))
- (when (tk-class self)
- (tk-format-now "~(~a~) ~a ~{~(~a~) ~a~^ ~}" ;; call to this GF now integrity-wrapped by caller
- (tk-class self) (path self)(tk-configurations self)))
- #+tryinafter (tkwin-register self)))
+ (when (tk-class self)
+ (tk-format-now "~(~a~) ~a ~{~(~a~) ~a~^ ~}" ;; call to this GF now integrity-wrapped by caller
+ (tk-class self) (path self)(tk-configurations self)))))
(defmethod make-tk-instance :after ((self widget))
(with-integrity (:client `(:post-make-tk ,self))
@@ -266,7 +263,7 @@
(defobserver image-files ()
(loop for (name file-pathname) in (set-difference new-value old-value :key 'car)
do (tk-format `(:pre-make-tk ,self) "image create photo ~(~a.~a~) -file {~a}"
- (^path) name (progn #+not tkescape (namestring file-pathname)))))
+ (^path) name (namestring file-pathname))))
;;; --- menus ---------------------------------
More information about the Cells-cvs
mailing list