Update of /project/cello/cvsroot/cello/cl-ftgl In directory clnet:/tmp/cvs-serv22618/cl-ftgl
Added Files: cl-ftgl.lisp cl-ftgl.lpr Log Message: CVS re-organization bringing auxiliary packages under one Cello module
--- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lisp 2006/05/17 16:14:29 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*- ;;; ;;; Copyright © 2004 by Kenneth William Tilton. ;;;;; ;;; Permission is hereby granted, free of charge, to any person obtaining a copy ;;; of this software and associated documentation files (the "Software"), to deal ;;; in the Software without restriction, including without limitation the rights ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;;; copies of the Software, and to permit persons to whom the Software is furnished ;;; to do so, subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be included in ;;; all copies or substantial portions of the Software. ;;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; 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.1 2006/05/17 16:14:29 ktilton Exp $
(defpackage #:cl-ftgl (:nicknames #:ftgl) (:use #:common-lisp #:cffi #:cl-opengl) (:export #:ftgl #:ftgl-pixmap #:ftgl-texture #:ftgl-bitmap #:ftgl-polygon #:ftgl-extruded #:ftgl-outline #:ftgl-string-length #:ftgl-get-ascender #:ftgl-get-descender #:ftgl-make #:cl-ftgl-init #:cl-ftgl-reset #:xftgl #:ftgl-render #:ftgl-font-ensure #:*ftgl-dynamic-lib-path* #:*font-directory-path* #:*gui-style-default-face* #:*gui-style-button-face*))
(in-package :cl-ftgl)
(define-foreign-library FTGL (:darwin (:framework "FTGL")) (:windows (:or "/0dev/user/dynlib/ftgl_dynamic_MTD_d.dll")))
(use-foreign-library FTGL)
(defparameter *gui-style-default-face* 'sylfaen) (defparameter *ftgl-loaded-p* nil) (defparameter *ftgl-fonts-loaded* nil)
;; ---------------------------------------------------------------------------- ;; FOREIGN FUNCTION INTERFACE ;; ----------------------------------------------------------------------------
(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 ("fgcAscender" fgc-ascender) :float (font :pointer))
(defcfun ("fgcDescender" fgc-descender) :float (font :pointer))
(defcfun ("fgcStringAdvance" fgc-string-advance) :float (font :pointer) (text :string))
(defcfun ("fgcStringX" fgc-string-x) :float (font :pointer)(text :string))
(defcfun ("fgcRender" fgc-render) :void (font :pointer)(text :string))
(defcfun ("fgcBuildGlyphs" fgc-build-glyphs) :void (font :pointer))
(defcfun ("fgcFree" fgc-free) :void (font :pointer))
(defcfun ("fgcBitmapMake" fgc-bitmap-make) :pointer (typeface :string)) (defcfun ("fgcPixmapMake" fgc-pixmap-make) :pointer (typeface :string)) (defcfun ("fgcTextureMake" fgc-texture-make) :pointer (typeface :string)) (defcfun ("fgcPolygonMake" fgc-polygon-make) :pointer (typeface :string)) (defcfun ("fgcOutlineMake" fgc-outline-make) :pointer (typeface :string)) (defcfun ("fgcExtrudedMake" fgc-extruded-make) :pointer (typeface :string))
(defcfun ("fgcSetFaceDepth" fgcSetFaceDepth) :unsigned-char (font :pointer)(depth :float))
(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") #+darwin '(:absolute "Library" "Fonts"))) ;; ---------------------------------------------------------------------------- ;; FUNCTIONS/METHODS ;; ----------------------------------------------------------------------------
(defun cl-ftgl-reset () #-mcl (setq *ftgl-loaded-p* nil)
(setq *ftgl-fonts-loaded* nil))
#+test (progn (cl-ftgl-init) (let ((sylfaen (ftgl-font-ensure :texture "Sylfaen" 24 96))) (print (list "sylfaen ascender" (ftgl-get-ascender sylfaen))) (print (list "sylfaen descender" (ftgl-get-descender sylfaen))) (print (list "sylfaen hello world length" (ftgl-string-length sylfaen "Hello world"))) (print (list "sylfaen disp font" (ftgl-get-display-font sylfaen))) ))
(defun cl-ftgl-init () (unless *ftgl-loaded-p* (assert (setq *ftgl-loaded-p* (use-foreign-library ftgl)))))
(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 ((f (apply 'ftgl-make fspec))) (push (cons fspec f) *ftgl-fonts-loaded*) 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) (:texture 'make-ftgl-texture) (:outline 'make-ftgl-outline) (:polygon 'make-ftgl-polygon) (:extruded 'make-ftgl-extruded)) :face face :size size :target-res target-res :depth depth))
;; --------- ftgl structure -----------------
(defstruct ftgl face size target-res depth descender ascender bboxes ifont)
(defstruct (ftgl-disp (:include ftgl)) ready-p)
(defstruct (ftgl-pixmap (:include ftgl-disp))) (defstruct (ftgl-texture (:include ftgl-disp))) (defstruct (ftgl-bitmap (:include ftgl))) (defstruct (ftgl-polygon (:include ftgl))) (defstruct (ftgl-extruded (:include ftgl-disp))) (defstruct (ftgl-outline (:include ftgl)))
(defmethod ftgl-ready (font) (declare (ignorable font)) t)
(defmethod (setf ftgl-ready) (new-value (font ftgl-disp)) (setf (ftgl-disp-ready-p font) new-value))
(defmethod (setf ftgl-ready) (new-value font) (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))
#+allegro (defun xftgl () (dolist (dll (ff:list-all-foreign-libraries)) (when (search "ftgl" (pathname-name dll)) (print `(unloading foreign library ,dll)) (ff:unload-foreign-library dll) (cl-ftgl-reset))))
(defun ftgl-get-ascender (font) (or (ftgl-ascender font) (setf (ftgl-ascender font) (fgc-ascender (ftgl-get-metrics-font font)))))
(defun ftgl-get-descender (font) (or (ftgl-descender font) (setf (ftgl-descender font) (fgc-descender (ftgl-get-metrics-font font)))))
(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)) (ukt::trc nil "ftgl-get-display-font> building glyphs for" font)
(fgc-build-glyphs cf) (ukt::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))
(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... ))
(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* ((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)) f) (error "cannot load ~a font ~a" (type-of font) fpath))) (error "Font not found: ~a" path))))
(defun 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)))))
(defmethod fgc-font-make :before (font fpath) (declare (ignore font fpath)) (cl-ftgl-init))
(defmethod fgc-font-make ((font ftgl-pixmap) fpath) (fgc-pixmap-make fpath))
(defmethod fgc-font-make ((font ftgl-bitmap) fpath) (fgc-bitmap-make fpath))
(defmethod fgc-font-make ((font ftgl-texture) fpath) (fgc-texture-make fpath))
(defmethod fgc-font-make ((font ftgl-extruded) fpath) (let ((fgc (fgc-extruded-make fpath))) (fgc-set-face-depth fgc (ftgl-depth font)) fgc))
(defmethod fgc-font-make ((font ftgl-outline) fpath) (fgc-outline-make fpath))
(defmethod fgc-font-make ((font ftgl-polygon) fpath) (fgc-polygon-make fpath))
(defun ftgl-string-length (font cs) (fgc-string-advance (ftgl-get-metrics-font font) cs))
(defmethod font-bearing-x ((font ftgl) &optional (text "m")) (fgc-string-x (ftgl-get-metrics-font font) text))
(defmethod font-bearing-x (font &optional text) (declare (ignorable font text)) 0)
--- /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/05/17 16:14:29 NONE +++ /project/cello/cvsroot/cello/cl-ftgl/cl-ftgl.lpr 2006/05/17 16:14:29 1.1 ;; -*- lisp-version: "8.0 [Windows] (Apr 21, 2006 10:24)"; cg: "1.81"; -*-
(in-package :cg-user)
(defpackage :CL-FTGL)
(define-project :name :cl-ftgl :modules (list (make-instance 'module :name "cl-ftgl.lisp")) :projects (list (make-instance 'project-module :name "C:\0devtools\cl-opengl\cl-opengl")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :cl-ftgl :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) :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) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+cx +t "Initializing"" :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard :on-initialization 'cl-ftgl::cl-ftgl-test :on-restart 'do-default-restart)
;; End of Project Definition
-
ktilton