Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv3905
Modified Files: cl-ftgl.lisp Log Message: Changed: Use new scheme to locate fonts. Needed on *nixes where fonts are in several locations.
--- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/08/25 08:28:16 1.10 +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/08/26 16:07:35 1.11 @@ -1,4 +1,4 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-ftgl; -*- ;;; ;;; Copyright © 2004 by Kenneth William Tilton. ;;;;; @@ -20,7 +20,7 @@ ;;; 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.10 2006/08/25 08:28:16 fgoenninger Exp $ +;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.11 2006/08/26 16:07:35 fgoenninger Exp $
(defpackage #:cl-ftgl (:nicknames #:ftgl) @@ -51,8 +51,8 @@ (in-package :cl-ftgl)
(define-foreign-library FTGL - (:darwin (:or "/opt/common-lisp/cello/cl-ftgl/ftgl-int/libFTGLint.dylib")) - (:windows (:or "/0dev/user/dynlib/ftgl_dynamic_MTD_d.dll"))) + (:darwin (:or "/opt/common-lisp/cello/cl-ftgl/ftgl-int/libFTGLint.dylib")) + (:windows (:or "/0dev/user/dynlib/ftgl_dynamic_MTD_d.dll")))
;;(use-foreign-library FTGL) - frgo: This leads to problems on OS X !!! ;; -> Use function cl-ftgl-init ! @@ -63,6 +63,60 @@ (defparameter *ftgl-fonts-loaded* nil) (defparameter *ftgl-ogl* nil)
+(defparameter *ftgl-font-pathnames-list* + + #+(or win32 windows) + (list + (make-pathname + :directory + '(:absolute "Windows" "fonts"))) + + #+linux + (list + (make-pathname + :directory + '(:absolute "usr" "share" "truetype"))) + + #+macosx + (list + (make-pathname + :directory + '(:absolute "System" "Library" "Fonts")) + (make-pathname + :directory + '(:absolute "Library" "Fonts")) + (make-pathname + :directory + '(:relative "~" "Library" "Fonts"))) +) + +(defparameter *ftgl-font-types-list* ;; list of font types + ;; (font filename endings) + #+(or win32 windows) + '("ttf") + + #+linux + '("ttf") + + #+macosx + '("dfont" "ttf") +) + + +(defun find-font-file (font) + (loop named pn-loop for pathname in *ftgl-font-pathnames-list* + do + (loop for ending in *ftgl-font-types-list* + do + (let ((pn (merge-pathnames (make-pathname + :name (string (ftgl-face font)) + :type ending) + pathname))) + (if (probe-file pn) + (progn + (format t "~%*** FIND-FONT-FILE: Result = ~A~%" pn) + (return-from pn-loop pn))))))) + ;; ---------------------------------------------------------------------------- ;; FOREIGN FUNCTION INTERFACE ;; ---------------------------------------------------------------------------- @@ -70,8 +124,8 @@ (defcfun ("fgcSetFaceSize" fgc-set-face-size) :unsigned-char (f :pointer)(size :int)(res :int))
-(defcfun ("fgcCharTexture" fgc-char-texture) :int - (f :pointer)(charCode :int)) +;; (defcfun ("fgcCharTexture" fgc-char-texture) :int +;; (f :pointer)(charCode :int))
(defcfun ("fgcAscender" fgc-ascender) :float (font :pointer)) @@ -88,8 +142,8 @@ (defcfun ("fgcRender" fgc-render) :void (font :pointer)(text :string))
-(defcfun ("fgcBuildGlyphs" fgc-build-glyphs) :void - (font :pointer)) +;; (defcfun ("fgcBuildGlyphs" fgc-build-glyphs) :void +;; (font :pointer))
(defcfun ("fgcFree" fgc-free) :void (font :pointer)) @@ -113,28 +167,16 @@ (defun fgc-set-face-depth (font depth) (fgcSetFaceDepth font (coerce depth 'float)))
-(defparameter *font-directory-path* - (make-pathname - :directory - #+(or win32 mswindows) - '(:absolute "windows" "fonts") - #+linux - '(:absolute "usr" "share" "fonts" "truetype") - #+macosx - '(:absolute "Library" "Fonts") - )) - ;; ---------------------------------------------------------------------------- ;; FUNCTIONS/METHODS ;; ----------------------------------------------------------------------------
(defun cl-ftgl-reset () -#-mcl +#-(or mcl macosx) (setq *ftgl-loaded-p* nil)
(setq *ftgl-fonts-loaded* nil))
- #+test (progn (cl-ftgl-init) @@ -145,19 +187,11 @@ (print (list "ArialHB disp font" (ftgl-get-display-font sylfaen))) ))
-#+frgo -(defun cl-ftgl-test () - (setf *ftgl-ogl* t) - (cl-ftgl-init) - (let ((sylfaen (ftgl-font-ensure :texture "ArialHB" 24 96))) - (print (list "ArialHB ascender" (ftgl-get-ascender sylfaen))) - (print (list "ArialHB descender" (ftgl-get-descender sylfaen))) - (print (list "ArialHB hello world length" (ftgl-string-length sylfaen "Hello world"))) - (print (list "ArialHB disp font" (ftgl-get-display-font sylfaen))))) - (defun cl-ftgl-init () - (unless *ftgl-loaded-p* - (assert (setq *ftgl-loaded-p* (use-foreign-library ftgl))))) + (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 ...
(defun ftgl-font-ensure (type face size target-res &optional (depth 0)) (let ((fspec (list type face size target-res depth))) @@ -167,7 +201,7 @@ 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) @@ -222,7 +256,6 @@ (declare (ignore new-value font)))
(defmethod ftgl-ready ((font ftgl-disp)) - ;(print (list "A cheerful HELLO from ftgl-ready: " font)) (ftgl-disp-ready-p font))
@@ -286,20 +319,17 @@ ))
(defun ftgl-font-make (font) - ;; (print (list "ftgl-font-make: entry" font)) - (let ((path (merge-pathnames - (make-pathname :name (string (ftgl-face font)) :type "ttf") - *font-directory-path*))) - (if (probe-file path) + (let ((path (find-font-file font))) + (if path (let* ((fpath (namestring path)) (f (fgc-font-make font fpath))) (if f (progn - ;;(ogl::dump-lists 1 10000) (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)))) + (error "cannot load ~a font ~a" (type-of font) fpath))) + (error "Font not found: ~a" path))))
(defmethod ftgl-render (font s) (assert font) @@ -327,6 +357,7 @@ (fgc-bitmap-make fpath))
(defmethod fgc-font-make ((font ftgl-texture) fpath) + (format t "~%*** FGC-FONT-MAKE: fpath = ~A~%" fpath) (fgc-texture-make fpath))
(defmethod fgc-font-make ((font ftgl-extruded) fpath) @@ -341,7 +372,6 @@ (fgc-polygon-make fpath))
(defun ftgl-string-length (font cs) - ;;(trc "ftgl-string-length" (ftgl-get-metrics-font font) cs) (fgc-string-advance (ftgl-get-metrics-font font) cs))
(defmethod font-bearing-x (font &optional text)