[cello-cvs] CVS cello/cl-ftgl
ktilton
ktilton at common-lisp.net
Wed May 17 16:14:29 UTC 2006
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
More information about the Cello-cvs
mailing list