[cello-cvs] CVS cello/cl-ftgl

ktilton ktilton at common-lisp.net
Mon Aug 28 21:45:25 UTC 2006


Update of /project/cello/cvsroot/cello/cl-ftgl
In directory clnet:/tmp/cvs-serv27660/cl-ftgl

Modified Files:
	cl-ftgl.lisp cl-ftgl.lpr 
Log Message:


--- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp	2006/08/26 16:07:35	1.11
+++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp	2006/08/28 21:45:24	1.12
@@ -20,7 +20,10 @@
 ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 
 ;;; IN THE SOFTWARE.
 
-;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.11 2006/08/26 16:07:35 fgoenninger Exp $
+;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.12 2006/08/28 21:45:24 ktilton Exp $
+
+(eval-when (:compile-toplevel :load-toplevel)
+  (pushnew :cl-ftgl *features*))
 
 (defpackage #:cl-ftgl
   (:nicknames #:ftgl)
@@ -65,7 +68,7 @@
 
 (defparameter *ftgl-font-pathnames-list*
 
-  #+(or win32 windows)
+  #+(or win32 windows mswindows)
   (list
     (make-pathname
       :directory
@@ -87,12 +90,12 @@
         '(:absolute "Library" "Fonts"))
     (make-pathname
       :directory
-        '(:relative "~" "Library" "Fonts")))
-)
+     '(:relative "~" "Library" "Fonts")))
+  )
 
 (defparameter *ftgl-font-types-list* ;; list of font types
                                      ;; (font filename endings)
-  #+(or win32 windows)
+  #+(or win32 windows mswindows)
   '("ttf")
 
   #+linux
@@ -114,7 +117,7 @@
 				       pathname)))
 	    (if (probe-file pn)
 	      (progn
-	        (format t "~%*** FIND-FONT-FILE: Result = ~A~%" pn)
+	        ;;(format t "~%*** FIND-FONT-FILE: Result = ~A~%" pn)
 	        (return-from pn-loop pn)))))))
 
 ;; ----------------------------------------------------------------------------
@@ -174,9 +177,28 @@
 (defun cl-ftgl-reset ()
 #-(or mcl macosx)  
   (setq *ftgl-loaded-p* nil) 
-
+  (cells::trc "nailing fonts loaded!!!!!!!!!!!!!")
   (setq *ftgl-fonts-loaded* nil))
 
+(defmacro dbgftgl (tag &body body)
+  (declare (ignorable tag))
+  `(progn
+     #+nahhh (unless (boundp '*gl-begun*)
+       (assert (zerop (glgeterror))))
+     #+nahhh (loop for (key . fonts) in (mathx::mp-fonts mathx::*font-node*)
+           when (eq key 'mathx::mathvar)
+           do (loop for font across fonts
+                    when (or (eql 12 (ftgl-size font))(ftgl-ifont font))
+                    do (cells::trc nil "dbgftgl sees ifont" ,tag (ftgl-face font)(ftgl-size font)(ftgl-ifont font))))
+     (progn ;; cells:wtrc (0 100 "dbgftgl" ,tag)
+       (ftgl-assert-opengl-context)
+       (unless (boundp '*gl-begun*) (glec :dbgftgl-entry))
+       (prog1
+           (progn , at body)
+         (unless (boundp '*gl-begun*)
+           (progn
+             (glec :dbgftgl-post-body)))))))
+
 #+test
 (progn
   (cl-ftgl-init)
@@ -189,19 +211,24 @@
 
 (defun cl-ftgl-init ()
   (unless *ftgl-loaded-p*
-    (assert (setq *ftgl-loaded-p* (use-foreign-library FTGL))))
-  (format *debug-io* "~%*** CL-FTGL-INIT: Loaded: ~S~%"
-	  *ftgl-loaded-p*)) ;; frgo: Debug ...
+    (assert (setq *ftgl-loaded-p* (use-foreign-library FTGL)))
+    (format *debug-io* "~%*** CL-FTGL-INIT: Loaded: ~S~%"
+      *ftgl-loaded-p*)))
 
 (defun ftgl-font-ensure (type face size target-res &optional (depth 0))
-  (let ((fspec (list type face size target-res depth)))
-    (or (cdr (assoc fspec *ftgl-fonts-loaded* :test 'equal))
+  (let* ((fspec (list type face size target-res depth))
+         (match (cdr (assoc fspec *ftgl-fonts-loaded* :test 'equal))))
+    #+shh (if match
+        (cells:trc "ftgl-font-ensure finds match" fspec (ftgl-ifont match))
+      (cells:trc "ftgl-font-ensure NO match"  fspec ))
+    (or match
       (let ((f (apply 'ftgl-make fspec)))
         (push (cons fspec f) *ftgl-fonts-loaded*)
+        (cells:trc nil "ftgl-font-ensure new font spec ifont" fspec (ftgl-ifont f))
         f))))
 
 (defun ftgl-make (type face size target-res &optional (depth 0))
-  (print (list "ftgl-make entry" type face size))
+  ;;(print (list "ftgl-make entry" type face size))
   (funcall (ecase type
              (:bitmap 'make-ftgl-bitmap)
              (:pixmap 'make-ftgl-pixmap)
@@ -217,12 +244,24 @@
 
 ;; --------- ftgl structure -----------------
 
+
 (defstruct ftgl
+  dbg
   face size target-res depth
   descender ascender 
   (widths (make-array 256 :initial-element nil))
   ft-metrics
-  ifont)
+  (ifont nil))
+
+(defun dbgfont (font calltag)
+  (declare (ignore font calltag))
+;;;  (cells::trc "dbgfont" calltag (ftgl-dbg font) (ftgl-face font)(ftgl-size font)(ftgl-ifont font))
+;;;  (unless (find font mathx::*font-node-all*)
+;;;    (cells::trc "dbgfont unknown!!!!! " calltag )
+;;;    (dolist (f mathx::*font-node-all*)
+;;;      (cells::trc "known" (ftgl-dbg f)(ftgl-face f)(ftgl-size f)))
+;;;    (break "odd font"))
+  )
 
 (defun ftgl-assert-opengl-context ()
   ;; use when debugging FTGL being hit before opengl context estanblished 
@@ -230,10 +269,11 @@
   )
 
 (defun ftgl-char-width (f c)
-  (ftgl-assert-opengl-context)
-  (or (aref (ftgl-widths f) (char-code c))
-    (setf (aref (ftgl-widths f) (char-code c))
-      (ftgl-string-length f (string c)))))
+  (assert (zerop (glgeterror)))
+  (dbgftgl :ftgl-char-width
+   (or (aref (ftgl-widths f) (char-code c))
+     (setf (aref (ftgl-widths f) (char-code c))
+       (ftgl-string-length f (string c))))))
 
 (defstruct (ftgl-disp (:include ftgl))
   ready-p)
@@ -271,52 +311,54 @@
 (xftgl)
 
 (defun ftgl-get-ascender (font)
-  (ftgl-assert-opengl-context)
-  (or (ftgl-ascender font)
-    (setf (ftgl-ascender font)
-        (fgc-ascender (ftgl-get-metrics-font font)))))
+  (cells:trc nil "ftgl-get-ascender" (ftgl-ifont font))
+  (dbgftgl :ftgl-get-ascender
+   (or (ftgl-ascender font)
+     (setf (ftgl-ascender font)
+       (fgc-ascender (ftgl-get-metrics-font font))))))
 
 (defun ftgl-get-descender (font)
-  (ftgl-assert-opengl-context)
-  (or (ftgl-descender font)
-    (setf (ftgl-descender font)
-        (fgc-descender (ftgl-get-metrics-font font)))))
+  (cells:trc nil "ftgl-get-descender" (ftgl-ifont font))
+  (dbgftgl :ftgl-get-descender
+   (or (ftgl-descender font)
+     (setf (ftgl-descender font)
+       (fgc-descender (ftgl-get-metrics-font font))))))
 
 (defun ftgl-height (f)
-  (ftgl-assert-opengl-context)
-  (- (ftgl-get-ascender f)
-    (ftgl-get-descender f)))
+  (cells:trc nil "ftgl-height" (ftgl-ifont f))
+  (dbgftgl :ftgl-height
+   (- (ftgl-get-ascender f)
+     (ftgl-get-descender f))))
 
 (defun ftgl-get-display-font (font)
-  (let ((cf (ftgl-get-metrics-font font)))
-    (assert cf)
-    ; (print (list "FTGL-GET-DISPLAY-FONT sees" (ftgl-disp-ready-p font)))
-    ;; (print (list "FTGL-GET-DISPLAY-FONT sees" (ftgl-ready font)))
-
-    (Unless (ftgl-ready font)
-     ; (when *ogl-listing-p*
-     ;   (cells::c-break "bad time #1 for sizing? ~a ~a" *ogl-listing-p* font))
-      (setf (ftgl-ready font) t)
-      (typecase font
-        (ftgl-extruded
-         #+nyet (let ((*ogl-listing-p* t))
-          (trc nil "ftgl-get-display-font> building glyphs for" font)
-           
-           (fgc-build-glyphs cf)
-           (trc nil "ftgl-get-display-font> glyphs built OK for" font)))
-        (ftgl-texture
-         #+no (fgc-set-face-size cf (ftgl-size font) (ftgl-target-res font)))
-        (ftgl-pixmap
-         #+no (fgc-set-face-size cf (ftgl-size font) (ftgl-target-res font)))))
-    cf))
+  (cells:trc nil "ftgl-get-display-font" (ftgl-ifont font))
+  (dbgftgl :ftgl-get-display-font
+   (let ((cf (ftgl-get-metrics-font font)))
+     (assert cf)
+     ; (print (list "FTGL-GET-DISPLAY-FONT sees" (ftgl-disp-ready-p font)))
+     ;; (print (list "FTGL-GET-DISPLAY-FONT sees" (ftgl-ready font)))
+     
+     (Unless (ftgl-ready font)
+       ; (when *ogl-listing-p*
+       ;   (cells::c-break "bad time #1 for sizing? ~a ~a" *ogl-listing-p* font))
+       (setf (ftgl-ready font) t)
+       (typecase font
+         (ftgl-extruded
+          #+nyet (let ((*ogl-listing-p* t))
+                   (cells:trc nil "ftgl-get-display-font> building glyphs for" font)
+                   
+                   (fgc-build-glyphs cf)
+                   (cells:trc nil "ftgl-get-display-font> glyphs built OK for" font)))
+         (ftgl-texture
+          #+no (fgc-set-face-size cf (ftgl-size font) (ftgl-target-res font)))
+         (ftgl-pixmap
+          #+no (fgc-set-face-size cf (ftgl-size font) (ftgl-target-res font)))))
+     (glec :ftgl-get-display-font)
+     cf)))
 
 (defun ftgl-get-metrics-font (font)
-  (prog1
-    (or (ftgl-ifont font)
-      (setf (ftgl-ifont font) (ftgl-font-make font)))
-
-    ;; (print (list "ftgl-get-metrics-font: exit" font)) ; frgo, ADDED: debug...
-    ))
+  (or (ftgl-ifont font)
+    (setf (ftgl-ifont font) (ftgl-font-make font))))
 
 (defun ftgl-font-make (font)
   (let ((path (find-font-file font)))
@@ -326,7 +368,6 @@
           (if f
               (progn
                 (fgc-set-face-size f (ftgl-size font) (ftgl-target-res font))
-;;		(setf (ftgl-ifont font) f)
                 f)
 	      (error "cannot load ~a font ~a" (type-of font) fpath)))
 	(error "Font not found: ~a" path))))
@@ -334,17 +375,23 @@
 (defmethod ftgl-render (font s)
   (assert font)
   (assert (stringp s))
-  (when font
-    (let ((df (ftgl-get-display-font font)))
-      (if df
-          (fgc-render df s)
-        (break "whoa, no display font for ~a" font)))))
+  (dbgfont font :ftgl-render)
+  (dbgftgl :ftgl-render
+   (when font
+     (let ((df (ftgl-get-display-font font)))
+       (ukt:trc nil "ftgl-render ing" df s (ftgl-face font) (ftgl-size font))
+       (if df
+           (fgc-render df s)
+         (break "whoa, no display font for ~a" font))))))
 
 (defmethod ftgl-render :before ((font ftgl-texture) s)
   (declare (ignorable s))
-  (gl-enable gl_texture_2d)
-  (gl-enable gl_blend)
-  (gl-disable gl_lighting))
+  (dbgfont font :ftgl-render-before)
+  
+  (dbgftgl :ftgl-render
+    (gl-enable gl_texture_2d)
+    (gl-enable gl_blend)
+    (gl-disable gl_lighting)))
     
 (defmethod fgc-font-make :before (font fpath)
   (declare (ignore font fpath))
@@ -357,7 +404,7 @@
   (fgc-bitmap-make fpath))
   
 (defmethod fgc-font-make ((font ftgl-texture) fpath)
-  (format t "~%*** FGC-FONT-MAKE: fpath = ~A~%" fpath)
+  ;;(format t "~%*** FGC-FONT-MAKE: fpath = ~A~%" fpath)
   (fgc-texture-make fpath))
 
 (defmethod fgc-font-make ((font ftgl-extruded) fpath)
--- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr	2006/08/21 04:28:27	1.7
+++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr	2006/08/28 21:45:24	1.8
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Aug 17, 2006 12:24)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Aug 24, 2006 21:48)"; cg: "1.81"; -*-
 
 (in-package :cg-user)
 




More information about the Cello-cvs mailing list