[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