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 ---------------------------------