[cello-cvs] CVS cello/cl-ftgl
fgoenninger
fgoenninger at common-lisp.net
Sat Aug 26 16:07:35 UTC 2006
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)
More information about the Cello-cvs
mailing list