[cells-cvs] CVS Celtk

[ktilton]

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