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

Modified Files: Celtk.lisp composites.lisp run.lisp togl.lisp Log Message:

--- /project/cells/cvsroot/Celtk/Celtk.lisp 2006/06/29 09:54:52 1.32 +++ /project/cells/cvsroot/Celtk/Celtk.lisp 2006/07/03 00:32:52 1.33 @@ -16,12 +16,13 @@

|#

-;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.32 2006/06/29 09:54:52 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/Celtk.lisp,v 1.33 2006/07/03 00:32:52 ktilton Exp $

(defpackage :celtk (:nicknames "CTK") (:use :common-lisp :utils-kt :cells :cffi) (:export + #:right #:left #:<1> #:tk-event-type #:xsv #:name #:x #:y #:x-root #:y-root #:title$ #:pop-up #:path #:parent-path #:^keyboard-modifiers #:keyboard-modifiers #:window #:panedwindow #:mk-row #:c?pack-self #:mk-stack #:mk-text-widget #:text-widget @@ -45,7 +46,7 @@ #:timer #:timers #:repeat #:executions #:state #:timer-reset #:make-timer-steps #:^widget-menu #:widget-menu #:tk-format-now #:coords #:^coords #:tk-translate-keysym - #:*tkw*)) + #:*tkw*))

(defpackage :celtk-user (:use :common-lisp :utils-kt :cells :celtk)) --- /project/cells/cvsroot/Celtk/composites.lisp 2006/06/29 09:54:52 1.11 +++ /project/cells/cvsroot/Celtk/composites.lisp 2006/07/03 00:32:52 1.12 @@ -107,26 +107,28 @@ (tk-format '(:fini new-value) "focus ~a" (path new-value))))

(defun tkfont-info-loader () - (c? (eko (nil "tkfinfo") - (loop with scaling = (^tk-scaling) - for (tkfont fname) in (^tkfonts-to-load) - collect (cons tkfont - (apply 'vector - (loop for fsize in (^tkfont-sizes-to-load) - for id = (format nil "~(~a-~2,'0d~)" tkfont fsize) - for tkf = (tk-eval "font create ~a -family {~a} -size ~a" - id fname fsize) - for (nil ascent nil descent nil linespace nil fixed) = (tk-eval-list "font metrics ~a" tkf) - collect (make-tkfinfo :ascent (round (parse-integer ascent) scaling) - :id id - :family fname - :size fsize - :descent (round (parse-integer descent) scaling) - :linespace (round (parse-integer linespace) scaling) - :fixed (plusp (parse-integer fixed)) - :em (round (parse-integer - (tk-eval "font measure ~(~a~) "m"" tkfont)) - scaling))))))))) + (c? (eko (nil "tkfinfo") + (loop with scaling = (^tk-scaling) + for (tkfont fname) in (^tkfonts-to-load) + collect (cons tkfont + (apply 'vector + (loop for fsize in (^tkfont-sizes-to-load) + for id = (format nil "~(~a-~2,'0d~)" tkfont fsize) + for tkf = (tk-eval "font create ~a -family {~a} -size ~a" + id fname fsize) + for (nil ascent nil descent nil linespace nil fixed) = (tk-eval-list "font metrics ~a" tkf) + collect + (progn (trc nil "tkfontloaded" id fname fsize tkfont tkf) + (make-tkfinfo :ascent (round (parse-integer ascent) scaling) + :id id + :family fname + :size fsize + :descent (round (parse-integer descent) scaling) + :linespace (round (parse-integer linespace) scaling) + :fixed (plusp (parse-integer fixed)) + :em (round (parse-integer + (tk-eval "font measure ~(~a~) "m"" tkfont)) + scaling))))))))))

(defobserver title$ ((self window)) (tk-format '(:configure "title") "wm title . ~s" (or new-value "Untitled"))) --- /project/cells/cvsroot/Celtk/run.lisp 2006/06/29 09:54:52 1.17 +++ /project/cells/cvsroot/Celtk/run.lisp 2006/07/03 00:32:52 1.18 @@ -23,7 +23,7 @@ (eval-when (compile load eval) (export '(tk-scaling run-window test-window)))

-(defun run-window (root-class &optional (resetp t)) +(defun run-window (root-class &optional (resetp t) &rest window-initargs) (declare (ignorable root-class)) (setf *tkw* nil) (when resetp @@ -49,8 +49,10 @@ (setf *app* (make-instance 'application :kids (c? (the-kids - (setf *tkw* (make-instance root-class - :fm-parent *parent*))))))) + (setf *tkw* (apply 'make-instance root-class + :fm-parent *parent* + window-initargs)))) + )))

(assert (tkwin *tkw*))

@@ -143,7 +145,7 @@

(defmethod window-idle ((self window)))

-(defun test-window (root-class &optional (resetp t)) +(defun test-window (root-class &optional (resetp t) &rest window-initargs) "nails existing window as a convenience in iterative development" (declare (ignorable root-class))

@@ -154,7 +156,7 @@ (force-output *tkw*) (setf *tkw* nil))

- (run-window root-class resetp)) + (apply 'run-window root-class resetp window-initargs))

;;; --- commands -----------------------------------------------------------------

--- /project/cells/cvsroot/Celtk/togl.lisp 2006/06/29 09:54:52 1.11 +++ /project/cells/cvsroot/Celtk/togl.lisp 2006/07/03 00:32:52 1.12 @@ -178,7 +178,9 @@ (defmethod ,(intern uc$) ((self togl))))))

(def-togl-callback create () - (setf (togl-ptr self) togl-ptr) + (trc "!!!!!!!!!!!!!!!!!! about to install togl-ptr!!!!!!!!!!!!!!!!!!" togl-ptr self) + (setf (togl-ptr self) (setf cl-ftgl::*ftgl-ogl* ;; help debug failure to use lazy cells/classes to defer FTGL till Ogl ready + togl-ptr)) (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self))

(def-togl-callback display ())