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
-
ktilton