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 ,@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)