[cello-cvs] CVS cello/cl-ftgl
ktilton
ktilton at common-lisp.net
Fri Apr 11 09:22:59 UTC 2008
Update of /project/cello/cvsroot/cello/cl-ftgl
In directory clnet:/tmp/cvs-serv7403/cl-ftgl
Modified Files:
cl-ftgl.lisp cl-ftgl.lpr
Log Message:
--- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2007/02/02 20:11:02 1.17
+++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2008/04/11 09:22:58 1.18
@@ -20,14 +20,14 @@
;;; 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.17 2007/02/02 20:11:02 ktilton Exp $
+;;; $Header: /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp,v 1.18 2008/04/11 09:22:58 ktilton Exp $
(eval-when (:compile-toplevel :load-toplevel)
(pushnew :cl-ftgl *features*))
(defpackage #:cl-ftgl
(:nicknames #:ftgl)
- (:use #:common-lisp #:cffi #:kt-opengl)
+ (:use #:common-lisp #:cffi #:kt-opengl #:utils-kt #:cells #:cl-freetype)
(:export #:ftgl
#:ftgl-pixmap
#:ftgl-texture
@@ -40,6 +40,7 @@
#:ftgl-get-ascender
#:ftgl-get-descender
#:ftgl-height
+ #:ftgl-filetype
#:ftgl-make
#:cl-ftgl-init
#:cl-ftgl-reset
@@ -47,6 +48,7 @@
#:ftgl-render
#:ftgl-font-ensure
#:ftgl-format
+ #:ftgl-ft-face
#:*font-directory-path*
#:*gui-style-default-face*
#:*gui-style-button-face*
@@ -57,73 +59,87 @@
;;; NOTE: Must build the ftgl-int/FTGLFromC.cpp glue library.
(define-foreign-library FTGL
(:darwin "libfgc.dylib")
- (:windows (:or "/0dev/user/dynlib/ftgl_dynamic_MTD_d.dll")))
+ (:windows (:or "ftgl_dynamic_MTD_d.dll")))
+
+#+test
+(inspect (cffi::get-foreign-library 'FTGL))
+
+#+test
+(probe-file (ukt:exe-dll "ftgl_dynamic_MTD_d"))
;;(use-foreign-library FTGL) - frgo: This leads to problems on OS X !!!
;; -> Use function cl-ftgl-init !
(defparameter *gui-style-default-face*
- #-cffi-features:darwin 'sylfaen
+ #-cffi-features:darwin "STIXGeneral" ;; "Sylfaen"
#+cffi-features:darwin "Helvetica")
(defparameter *gui-style-button-face*
- #-cffi-features:darwin 'sylfaen
+ #-cffi-features:darwin "STIXGeneral" ;; "Sylfaen"
#+cffi-features:darwin "Helvetica")
(defparameter *ftgl-loaded-p* nil)
(defparameter *ftgl-fonts-loaded* nil)
(defparameter *ftgl-ogl* nil)
-(defparameter *ftgl-font-pathnames-list*
-
- #+cffi-features:windows
- (list
- (make-pathname
- :directory
- '(:absolute "Windows" "fonts")))
+(defparameter *ftgl-font-dirs* nil)
- #+cffi-features:darwin
- (list
- (make-pathname
- :directory
+(defun ftgl-font-directories ()
+ (or *ftgl-font-dirs*
+ (setf *ftgl-font-dirs*
+ #+cffi-features:windows
+ (list (font-path)
+ (make-pathname
+ :directory
+ '(:absolute "Windows" "fonts")))
+ #+cffi-features:darwin
+ (list
+ (make-pathname
+ :directory
'(:absolute "System" "Library" "Fonts"))
- (make-pathname
- :directory
+ (make-pathname
+ :directory
'(:absolute "Library" "Fonts"))
- (make-pathname
- :directory
- '(:relative "~" "Library" "Fonts")))
-
- #+(and cffi-features:unix (not cffi-features:darwin))
- (list
- (make-pathname
- :directory
- '(:absolute "usr" "share" "truetype")))
- )
+ (make-pathname
+ :directory
+ '(:relative "~" "Library" "Fonts")))
+
+ #+(and cffi-features:unix (not cffi-features:darwin))
+ (list
+ (make-pathname
+ :directory
+ '(:absolute "usr" "share" "truetype"))))))
(defparameter *ftgl-font-types-list* ;; list of font types
- ;; (font filename endings)
+ ;; (font filename endings)
#+cffi-features:darwin
'("dfont" "ttf")
#+(or cffi-features:windows (and cffi-features:unix (not cffi-features:darwin)))
- '("ttf")
-)
-
+ '("ttf" "otf"))
(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)))))))
+ (trc nil "find.font.file> seeks" (ftgl-face font) :n (ftgl-font-directories))
+ (or
+ (loop for dir in (ftgl-font-directories)
+ thereis (loop for ending in *ftgl-font-types-list*
+ thereis (probe-file (merge-pathnames (make-pathname
+ :name (string (ftgl-face font))
+ :type ending)
+ dir))))
+ (loop initially (trc "find.font.file cant find any of"
+ (loop for ending in *ftgl-font-types-list*
+ collecting (make-pathname
+ :name (string (ftgl-face font))
+ :type ending)))
+ for dir in (ftgl-font-directories) do
+ (loop for f in (directory dir)
+ when (and (string-equal (pathname-type f) "TTF")
+ (string-equal (pathname-name f) (string (ftgl-face font))))
+ do (trc "...does see" (namestring f))))))
+
+#+test
+(probe-file "C:\\0Algebra\\TYExtender\\font\\Sylfaen.ttf")
(defun ftgl-format (font control-string &rest args)
(ftgl-render font (apply 'format nil control-string args)))
@@ -185,8 +201,15 @@
(defun cl-ftgl-reset ()
#-(or mcl macosx)
(setq *ftgl-loaded-p* nil)
+ #+noway (loop for (nil . font) in *ftgl-fonts-loaded*
+ do (fgc-free (ftgl-ifont font)))
(setq *ftgl-fonts-loaded* nil))
+#+test
+(progn
+ (mgk:wands-clear)
+ (cl-ftgl-reset))
+
(defmacro dbgftgl (tag &body body)
(declare (ignorable tag))
`(progn
@@ -204,33 +227,40 @@
#+test
(progn
(cl-ftgl-init)
- (let ((sylfaen (ftgl-font-ensure :texture |ArialHB| 24 96)))
+ (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 ()
+ (initialize-ft)
(unless *ftgl-loaded-p*
(assert (setq *ftgl-loaded-p* (use-foreign-library FTGL)))
(format *debug-io* "~%*** CL-FTGL-INIT: Loaded: ~S~%"
*ftgl-loaded-p*)))
+#+test
+(loop for (fspec . f) in *ftgl-fonts-loaded*
+ do (print (list fspec f)))
(defun ftgl-font-ensure (type face size target-res &optional (depth 0))
(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 ))
+ #+shhh (if match
+ (progn (cells::trc "ftgl-font-ensure finds match" fspec (ftgl-ifont match)))
+ (cells::trc "ftgl-font-ensure NO match" fspec :in #+shhh (loop for (fspec nil) in *ftgl-fonts-loaded*
+ collecting 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))
+ ;; (cells::trc "ftgl-font-ensure allocating!!!!!!!!!!! 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))
+
(funcall (ecase type
(:bitmap 'make-ftgl-bitmap)
(:pixmap 'make-ftgl-pixmap)
@@ -252,6 +282,8 @@
face size target-res depth
descender ascender
(widths (make-array 256 :initial-element nil))
+ ft-face
+ filetype
ft-metrics
(ifont nil))
@@ -303,22 +335,36 @@
(ff:unload-foreign-library dll)
(cl-ftgl-reset))))
+#+test
+(dolist (dll (ff:list-all-foreign-libraries))
+ (when t ;(search "free" (pathname-name dll) :test 'string-equal)
+ (print `(foreign library ,dll))))
+
#+doit
(xftgl)
(defun ftgl-get-ascender (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))))))
+ (or (ftgl-ascender font)
+ (setf (ftgl-ascender font)
+ (eko (nil "ftgl.get.ascender" font)
+ (let ((mf (ftgl-get-metrics-font font))) ; also loads face
+ (if (string-equal (ftgl-face font) "math2___")
+ (ftgl-size font)
+ #+yeahyeah (round (ft:ft-glyphslotrec/metrics/hori-bearing/y
+ (ft:load-glyph (ftgl-ft-face font) 0 3)) 96)
+ (fgc-ascender mf))))))))
(defun ftgl-get-descender (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))))))
+ (eko (nil "ftgl.get.descender" font)
+ (if (string-equal (ftgl-face font) "math2___")
+ (round (ftgl-size font) -2)
+ (fgc-descender (ftgl-get-metrics-font font))))))))
(defun ftgl-height (f)
(cells:trc nil "ftgl-height" (ftgl-ifont f))
@@ -335,8 +381,9 @@
;; (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))
+ (cells:trc "ftgl-get-display-font" (ftgl-face font) (ftgl-size font)(ftgl-ifont font))
+ (when *ogl-listing-p*
+ (cells::c-break "bad time #1 for sizing? ~a ~a" *ogl-listing-p* (cons (ftgl-face font)(ftgl-size font))(ftgl-ifont font)))
(setf (ftgl-ready font) t)
(typecase font
(ftgl-extruded
@@ -346,7 +393,7 @@
(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)))
+ #+fails (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)
@@ -357,16 +404,32 @@
(setf (ftgl-ifont font) (ftgl-font-make font))))
(defun ftgl-font-make (font)
- (let ((path (find-font-file font)))
- (if path
- (let* ((fpath (namestring path))
- (f (fgc-font-make font fpath)))
- (if f
- (progn
- (fgc-set-face-size f (ftgl-size font) (ftgl-target-res font))
- f)
- (error "cannot load ~a font ~a" (type-of font) fpath)))
- (error "Font not found: ~a" path))))
+ (eko (nil "made cpp FTGL font ~a" (ftgl-face font)(ftgl-size font))
+ (bif (path (find-font-file font))
+ (let ((fpath (namestring path)))
+ (bif (f (fgc-font-make font fpath))
+ (progn
+ (prog1
+ (setf (ftgl-ft-face font) (ft:get-new-face (namestring path)))
+ ;(trc "making!!!!!!!!!!!! afce!!!!!!" (ftgl-face font))
+ (assert (ftgl-ft-face font)))
+ (ft:set-char-size (ftgl-ft-face font) (ft:to-ft (ftgl-size font)) (ftgl-target-res font))
+ #+shhh (loop with size = (ft:ft-facerec/size (ftgl-ft-face font))
+ for (k m) on (list :x-ppem (ft:ft-sizerec/metrics/x-ppem size)
+ :y-ppem (ft:ft-sizerec/metrics/y-ppem size)
+ :x-scale (ft:ft-sizerec/metrics/x-scale size)
+ :y-scale (ft:ft-sizerec/metrics/y-scale size)
+ :ascender (ft:ft-sizerec/metrics/ascender size)
+ :descender (ft:ft-sizerec/metrics/descender size)
+ :height (ft:ft-sizerec/metrics/height size)
+ :max-advance (ft:ft-sizerec/metrics/max-advance size)) by #'cddr
+ do (print (list k (ft:from-ft m))))
+
+ (setf (ftgl-filetype font) (intern (up$ (pathname-type path)) :keyword))
+ (fgc-set-face-size f (ftgl-size font) (ftgl-target-res font))
+ f)
+ (error "cannot load ~a font ~a" (type-of font) fpath)))
+ (error "Font not found: ~a" path))))
(defmethod ftgl-render (font s)
(assert font)
@@ -374,11 +437,11 @@
(dbgfont font :ftgl-render)
(dbgftgl :ftgl-render
(when font
- (let ((df (ftgl-get-display-font font)))
- (cells: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))))))
+ (fgc-render (ftgl-get-metrics-font font) s))))
+
+(defmethod ftgl-render :before ((font ftgl-extruded) s)
+ (declare (ignorable s))
+ (ftgl-get-display-font font))
(defmethod ftgl-render :before ((font ftgl-texture) s)
(declare (ignorable s))
@@ -400,7 +463,7 @@
(fgc-bitmap-make fpath))
(defmethod fgc-font-make ((font ftgl-texture) fpath)
- (format *debug-io* "~%*** FGC-FONT-MAKE: fpath = ~A~%" fpath)
+ (format *debug-io* "~%*** FGC-FONT-MAKE: texture fpath = ~A~%" fpath)
(fgc-texture-make fpath))
(defmethod fgc-font-make ((font ftgl-extruded) fpath)
--- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2007/02/02 20:11:03 1.11
+++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2008/04/11 09:22:58 1.12
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.1 [Windows] (Jan 2, 2008 9:44)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
@@ -17,64 +17,72 @@
:main-form nil
:compilation-unit t
:verbose nil
- :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane
- :cg.bitmap-pane.clipboard :cg.bitmap-stream
- :cg.button :cg.caret :cg.check-box :cg.choice-list
- :cg.choose-printer :cg.clipboard
- :cg.clipboard-stack :cg.clipboard.pixmap
- :cg.color-dialog :cg.combo-box :cg.common-control
- :cg.comtab :cg.cursor-pixmap :cg.curve
- :cg.dialog-item :cg.directory-dialog
- :cg.directory-dialog-os :cg.drag-and-drop
- :cg.drag-and-drop-image :cg.drawable
- :cg.drawable.clipboard :cg.dropping-outline
- :cg.edit-in-place :cg.editable-text
- :cg.file-dialog :cg.fill-texture
- :cg.find-string-dialog :cg.font-dialog
- :cg.gesture-emulation :cg.get-pixmap
- :cg.get-position :cg.graphics-context
- :cg.grid-widget :cg.grid-widget.drag-and-drop
- :cg.group-box :cg.header-control :cg.hotspot
- :cg.html-dialog :cg.html-widget :cg.icon
- :cg.icon-pixmap :cg.ie :cg.item-list
- :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu
- :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget
- :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip
- :cg.message-dialog :cg.multi-line-editable-text
- :cg.multi-line-lisp-text :cg.multi-picture-button
- :cg.multi-picture-button.drag-and-drop
- :cg.multi-picture-button.tooltip :cg.ocx
- :cg.os-widget :cg.os-window :cg.outline
- :cg.outline.drag-and-drop
- :cg.outline.edit-in-place :cg.palette
- :cg.paren-matching :cg.picture-widget
- :cg.picture-widget.palette :cg.pixmap
- :cg.pixmap-widget :cg.pixmap.file-io
- :cg.pixmap.printing :cg.pixmap.rotate :cg.printing
- :cg.progress-indicator :cg.project-window
- :cg.property :cg.radio-button :cg.rich-edit
- :cg.rich-edit-pane :cg.rich-edit-pane.clipboard
- :cg.rich-edit-pane.printing :cg.sample-file-menu
- :cg.scaling-stream :cg.scroll-bar
- :cg.scroll-bar-mixin :cg.selected-object
- :cg.shortcut-menu :cg.static-text :cg.status-bar
- :cg.string-dialog :cg.tab-control
- :cg.template-string :cg.text-edit-pane
- :cg.text-edit-pane.file-io :cg.text-edit-pane.mark
- :cg.text-or-combo :cg.text-widget :cg.timer
- :cg.toggling-widget :cg.toolbar :cg.tooltip
- :cg.trackbar :cg.tray :cg.up-down-control
- :cg.utility-dialog :cg.web-browser
- :cg.web-browser.dde :cg.wrap-string
- :cg.yes-no-list :cg.yes-no-string :dde)
+ :runtime-modules (list :cg-dde-utils :cg.base :cg.bitmap-pane
+ :cg.bitmap-pane.clipboard :cg.bitmap-stream
+ :cg.button :cg.caret :cg.check-box
+ :cg.choice-list :cg.choose-printer
+ :cg.clipboard :cg.clipboard-stack
+ :cg.clipboard.pixmap :cg.color-dialog
+ :cg.combo-box :cg.common-control :cg.comtab
+ :cg.cursor-pixmap :cg.curve :cg.dialog-item
+ :cg.directory-dialog :cg.directory-dialog-os
+ :cg.drag-and-drop :cg.drag-and-drop-image
+ :cg.drawable :cg.drawable.clipboard
+ :cg.dropping-outline :cg.edit-in-place
+ :cg.editable-text :cg.file-dialog
+ :cg.fill-texture :cg.find-string-dialog
+ :cg.font-dialog :cg.gesture-emulation
+ :cg.get-pixmap :cg.get-position
+ :cg.graphics-context :cg.grid-widget
+ :cg.grid-widget.drag-and-drop :cg.group-box
+ :cg.header-control :cg.hotspot :cg.html-dialog
+ :cg.html-widget :cg.icon :cg.icon-pixmap
+ :cg.ie :cg.item-list :cg.keyboard-shortcuts
+ :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane
+ :cg.lisp-text :cg.lisp-widget :cg.list-view
+ :cg.mci :cg.menu :cg.menu.tooltip
+ :cg.message-dialog
+ :cg.multi-line-editable-text
+ :cg.multi-line-lisp-text
+ :cg.multi-picture-button
+ :cg.multi-picture-button.drag-and-drop
+ :cg.multi-picture-button.tooltip :cg.ocx
+ :cg.os-widget :cg.os-window :cg.outline
+ :cg.outline.drag-and-drop
+ :cg.outline.edit-in-place :cg.palette
+ :cg.paren-matching :cg.picture-widget
+ :cg.picture-widget.palette :cg.pixmap
+ :cg.pixmap-widget :cg.pixmap.file-io
+ :cg.pixmap.printing :cg.pixmap.rotate
+ :cg.printing :cg.progress-indicator
+ :cg.project-window :cg.property
+ :cg.radio-button :cg.rich-edit
+ :cg.rich-edit-pane
+ :cg.rich-edit-pane.clipboard
+ :cg.rich-edit-pane.printing
+ :cg.sample-file-menu :cg.scaling-stream
+ :cg.scroll-bar :cg.scroll-bar-mixin
+ :cg.selected-object :cg.shortcut-menu
+ :cg.static-text :cg.status-bar
+ :cg.string-dialog :cg.tab-control
+ :cg.template-string :cg.text-edit-pane
+ :cg.text-edit-pane.file-io
+ :cg.text-edit-pane.mark :cg.text-or-combo
+ :cg.text-widget :cg.timer :cg.toggling-widget
+ :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray
+ :cg.up-down-control :cg.utility-dialog
+ :cg.web-browser :cg.web-browser.dde
+ :cg.wrap-string :cg.yes-no-list
+ :cg.yes-no-string :dde)
:splash-file-module (make-instance 'build-module :name "")
:icon-file-module (make-instance 'build-module :name "")
- :include-flags '(:compiler :top-level :local-name-info)
- :build-flags '(:allow-debug :purify)
+ :include-flags (list :compiler :top-level :local-name-info)
+ :build-flags (list :allow-debug :purify)
:autoload-warning t
:full-recompile-for-runtime-conditionalizations nil
+ :include-manifest-file-for-visual-styles t
:default-command-line-arguments "+cx +t \"Initializing\""
- :additional-build-lisp-image-arguments '(:read-init-files nil)
+ :additional-build-lisp-image-arguments (list :read-init-files nil)
:old-space-size 256000
:new-space-size 6144
:runtime-build-option :standard
More information about the Cello-cvs
mailing list