From ac1caa84cc0541923176acf12de322b115ed2d74 Mon Sep 17 00:00:00 2001 From: Robert Goldman Date: Thu, 25 May 2006 19:23:22 +0000 Subject: First shot at a CFFI-based freetype to replace sbcl/cmucl-specific original. --- Experimental/freetype/freetype-cffi.lisp | 490 +++++++++++++++++ Experimental/freetype/freetype-fonts-cffi.lisp | 635 +++++++++++++++++++++++ Experimental/freetype/freetype-package-cffi.lisp | 82 +++ Experimental/freetype/mcclim-freetype-cffi.asd | 86 +++ 4 files changed, 1293 insertions(+) create mode 100644 Experimental/freetype/freetype-cffi.lisp create mode 100644 Experimental/freetype/freetype-fonts-cffi.lisp create mode 100644 Experimental/freetype/freetype-package-cffi.lisp create mode 100644 Experimental/freetype/mcclim-freetype-cffi.asd (limited to 'Experimental') diff --git a/Experimental/freetype/freetype-cffi.lisp b/Experimental/freetype/freetype-cffi.lisp new file mode 100644 index 00000000..4df3cf9e --- /dev/null +++ b/Experimental/freetype/freetype-cffi.lisp @@ -0,0 +1,490 @@ +;;; automatically generated, hand tweaked, do not regenerate. + +(in-package :freetype) + +(define-foreign-library libfreetype + (:unix (:or "libfreetype.so.6" "libfreetype")) + (t (:default "libfreetype"))) +(use-foreign-library libfreetype) + +(defmacro define-alien-type (&rest rest) + ;; cffi seems to have a much simpler model of pointer + ;; types... [2006/05/23:rpg] + (cond ((and (= (length rest) 2) + (eq (car (second rest)) '*)) + `(defctype ,(first rest) :pointer)) + ((error "Don't understand how to translate alien type definition ~S" + `(define-alien-type ,@rest))))) + +(defmacro define-alien-routine (name retval &rest args) + `(defcfun ,name ,retval + ,@(loop for (name type) in args + for new-type = (if (and (listp type) + (eq (car type) '*)) + :pointer + type) + collect (list name new-type)))) + +(defmacro defcstruct (name &rest slots) + `(cffi:defcstruct ,name + ,@(loop for (name type) in slots + for new-type = (if (and (listp type) + (eq (car type) '*)) + :pointer + type) + collect (list name new-type)))) + +(declaim (optimize (speed 3))) + +(define-alien-type freetype:memory (* (struct freetype::memory-rec-))) +(define-alien-type freetype:stream (* (struct freetype::stream-rec-))) +(define-alien-type freetype:raster (* (struct freetype::raster-rec-))) +(define-alien-type freetype:list-node (* (struct freetype::list-node-rec-))) +(define-alien-type freetype:list (* (struct freetype::list-rec-))) +(define-alien-type freetype:library (* (struct freetype::library-rec-))) +(define-alien-type freetype:module (* (struct freetype::module-rec-))) +(define-alien-type freetype:driver (* (struct freetype::driver-rec-))) +(define-alien-type freetype:renderer (* (struct freetype::renderer-rec-))) +(define-alien-type freetype:char-map (* (struct freetype::char-map-rec-))) +(define-alien-type freetype:face-internal (* (struct freetype::face-internal-rec-))) +(define-alien-type freetype:slot-internal (* (struct freetype::slot-internal-rec-))) +(define-alien-type freetype:size-internal (* (struct freetype::size-internal-rec-))) + +(defctype freetype:int16 :int16) + +(defctype freetype:uint16 :uint16) + +(defctype freetype:int32 :int32) + +(defctype freetype:uint32 :uint32) + +(defctype freetype:fast :int32) + +(defctype freetype:ufast :uint32) + +(defctype freetype:ptrdiff-t :int32) + +(defctype freetype:size-t :uint32) + +(defctype freetype:wchar-t :int32) + +(defctype freetype:wint-t :uint32) + +(defctype freetype:bool :uint8) + +(defctype freetype:fword :int16) + +(defctype freetype:ufword :uint16) + +(defctype freetype:char :int8) + +(defctype freetype:byte :uint8) + +(defctype freetype:string :int8) + +(defctype freetype:short :int16) + +(defctype freetype:ushort :uint16) + +(defctype freetype:int :int32) + +(defctype freetype:uint :uint32) + +(defctype freetype:long :long) + +(defctype freetype:ulong :unsigned-long) + +(defctype freetype:f2dot14 :int16) + +(defctype freetype:f26dot6 :long) + +(defctype freetype:fixed :long) + +(defctype freetype:error :int32) + +(defctype freetype:pointer :pointer) + +(defctype freetype:offset freetype:size-t) + +(defctype freetype:ptr-dist freetype:size-t) + +(define-alien-type freetype:face (* freetype:face-rec)) + + +(defcenum mod-err + (:mod-err-base #.#x000) + (:mod-err-autohint #.#x100) (:mod-err-cache #.#x200) (:mod-err-cff #.#x300) + (:mod-err-cid #.#x400) (:mod-err-pcf #.#x500) (:mod-err-psaux #.#x600) (:mod-err-psnames #.#x700) (:mod-err-raster #.#x800) + (:mod-err-sfnt #.#x900) (:mod-err-smooth #.#xA00) (:mod-err-true-type #.#xB00) (:mod-err-type1 #.#xC00) + (:mod-err-winfonts #.#xD00) + :mod-err-max) + +(defcenum error-enum + (:err-ok #.#x00) (:err-cannot-open-resource #.(+ #x01 0)) (:err-unknown-file-format #.(+ #x02 0)) + (:err-invalid-file-format #.(+ #x03 0)) (:err-invalid-version #.(+ #x04 0)) (:err-lower-module-version #.(+ #x05 0)) + (:err-invalid-argument #.(+ #x06 0)) (:err-unimplemented-feature #.(+ #x07 0)) (:err-invalid-glyph-index #.(+ #x10 0)) + (:err-invalid-character-code #.(+ #x11 0)) (:err-invalid-glyph-format #.(+ #x12 0)) (:err-cannot-render-glyph #.(+ #x13 0)) + (:err-invalid-outline #.(+ #x14 0)) (:err-invalid-composite #.(+ #x15 0)) (:err-too-many-hints #.(+ #x16 0)) + (:err-invalid-pixel-size #.(+ #x17 0)) (:err-invalid-handle #.(+ #x20 0)) (:err-invalid-library-handle #.(+ #x21 0)) + (:err-invalid-driver-handle #.(+ #x22 0)) (:err-invalid-face-handle #.(+ #x23 0)) (:err-invalid-size-handle #.(+ #x24 0)) + (:err-invalid-slot-handle #.(+ #x25 0)) (:err-invalid-char-map-handle #.(+ #x26 0)) (:err-invalid-cache-handle #.(+ #x27 0)) + (:err-invalid-stream-handle #.(+ #x28 0)) (:err-too-many-drivers #.(+ #x30 0)) (:err-too-many-extensions #.(+ #x31 0)) + (:err-out-of-memory #.(+ #x40 0)) (:err-unlisted-object #.(+ #x41 0)) (:err-cannot-open-stream #.(+ #x51 0)) + (:err-invalid-stream-seek #.(+ #x52 0)) (:err-invalid-stream-skip #.(+ #x53 0)) (:err-invalid-stream-read #.(+ #x54 0)) + (:err-invalid-stream-operation #.(+ #x55 0)) (:err-invalid-frame-operation #.(+ #x56 0)) + (:err-nested-frame-access #.(+ #x57 0)) (:err-invalid-frame-read #.(+ #x58 0)) (:err-raster-uninitialized #.(+ #x60 0)) + (:err-raster-corrupted #.(+ #x61 0)) (:err-raster-overflow #.(+ #x62 0)) (:err-raster-negative-height #.(+ #x63 0)) + (:err-too-many-caches #.(+ #x70 0)) (:err-invalid-opcode #.(+ #x80 0)) (:err-too-few-arguments #.(+ #x81 0)) + (:err-stack-overflow #.(+ #x82 0)) (:err-code-overflow #.(+ #x83 0)) (:err-bad-argument #.(+ #x84 0)) + (:err-divide-by-zero #.(+ #x85 0)) (:err-invalid-reference #.(+ #x86 0)) (:err-debug-op-code #.(+ #x87 0)) + (:err-endf-in-exec-stream #.(+ #x88 0)) (:err-nested-defs #.(+ #x89 0)) (:err-invalid-code-range #.(+ #x8A 0)) + (:err-execution-too-long #.(+ #x8B 0)) (:err-too-many-function-defs #.(+ #x8C 0)) + (:err-too-many-instruction-defs #.(+ #x8D 0)) (:err-table-missing #.(+ #x8E 0)) (:err-horiz-header-missing #.(+ #x8F 0)) + (:err-locations-missing #.(+ #x90 0)) (:err-name-table-missing #.(+ #x91 0)) (:err-cmap-table-missing #.(+ #x92 0)) + (:err-hmtx-table-missing #.(+ #x93 0)) (:err-post-table-missing #.(+ #x94 0)) (:err-invalid-horiz-metrics #.(+ #x95 0)) + (:err-invalid-char-map-format #.(+ #x96 0)) (:err-invalid-ppem #.(+ #x97 0)) (:err-invalid-vert-metrics #.(+ #x98 0)) + (:err-could-not-find-context #.(+ #x99 0)) (:err-invalid-post-table-format #.(+ #x9A 0)) + (:err-invalid-post-table #.(+ #x9B 0)) (:err-syntax-error #.(+ #xA0 0)) (:err-stack-underflow #.(+ #xA1 0)) :err-max) + +(defctype freetype:alloc-func :pointer) + +(defctype freetype:free-func :pointer) + +(defctype freetype:realloc-func :pointer) + +(defcstruct freetype::memory-rec- + (freetype:user :pointer) (freetype:alloc freetype:alloc-func) (freetype:free freetype:free-func) + (freetype:realloc freetype:realloc-func)) + +(defcunion freetype:stream-desc + (freetype:value :long) + (freetype:pointer :pointer)) + +(defctype freetype:stream-io :pointer) + +(defctype freetype:stream-close :pointer) + +(defcstruct freetype::stream-rec- + (freetype:base (* :uint8)) + (freetype:size freetype:ulong) + (freetype:pos freetype:ulong) + (freetype:descriptor freetype:stream-desc) + (freetype:pathname freetype:stream-desc) + (freetype:read freetype:stream-io) + (freetype:close freetype:stream-close) + (freetype:memory freetype:memory) + (freetype:cursor (* :uint8)) + (freetype:limit (* :uint8))) + +(defctype freetype:pos :long) + +(defcstruct freetype:vector (freetype:x freetype:pos) (freetype:y freetype:pos)) + +(defcstruct freetype:bbox + (freetype:x-min freetype:pos) (freetype:y-min freetype:pos) (freetype:x-max freetype:pos) + (freetype:y-max freetype:pos)) + +;; seems like pixel-mode- might possibly be an alias for this... +(defcenum freetype:pixel-mode + (:ft-pixel-mode-none #.#o0) :ft-pixel-mode-mono :ft-pixel-mode-grays :ft-pixel-mode-pal2 + :ft-pixel-mode-pal4 :ft-pixel-mode-pal8 :ft-pixel-mode-rgb15 :ft-pixel-mode-rgb16 :ft-pixel-mode-rgb24 :ft-pixel-mode-rgb32 + :ft-pixel-mode-max) + +;;; palette-mode- +(defcenum freetype:palette-mode + (:ft-palette-mode-rgb #.#o0) :ft-palette-mode-rgba :ft-palettte-mode-max) + +(defcstruct freetype:bitmap + (freetype:rows :int32) (freetype:width :int32) (freetype:pitch :int32) + (freetype:buffer (* :uint8)) (freetype:num-grays :int16) (freetype:pixel-mode :int8) + (freetype:palette-mode :int8) (freetype:palette :pointer)) + +(defcstruct freetype:outline + (freetype:n-contours :int16) (freetype:n-points :int16) + (freetype:points (* freetype:vector)) (freetype:tags (* :int8)) (freetype:contours (* :int16)) + (freetype:flags :int32)) + +(defcenum freetype:outline-flags + (:ft-outline-none #.#o0) (:ft-outline-owner #.1) (:ft-outline-even-odd-fill #.2) + (:ft-outline-reverse-fill #.4) (:ft-outline-ignore-dropouts #.8) (:ft-outline-high-precision #.256) + (:ft-outline-single-pass #.512)) + +(defctype freetype:outline-move-to-func :pointer) + +(defctype freetype:outline-line-to-func :pointer) + +(defctype freetype:outline-conic-to-func :pointer) + +(defctype freetype:outline-cubic-to-func :pointer) + +(defcstruct freetype:outline-funcs + (freetype:move-to freetype:outline-move-to-func) + (freetype:line-to freetype:outline-line-to-func) (freetype:conic-to freetype:outline-conic-to-func) + (freetype:cubic-to freetype:outline-cubic-to-func) (freetype:shift :int32) (freetype:delta freetype:pos)) + +(defcenum freetype:glyph-format + (:ft-glyph-format-none #.(logior (logior (logior (ash #o0 24) (ash #o0 16)) (ash #o0 8)) #o0)) + (:ft-glyph-format-composite + #.(logior (logior (logior (ash #.(char-code #\c) 24) (ash #.(char-code #\o) 16)) (ash #.(char-code #\m) 8)) + #.(char-code #\p))) + (:ft-glyph-format-bitmap + #.(logior (logior (logior (ash #.(char-code #\b) 24) (ash #.(char-code #\i) 16)) (ash #.(char-code #\t) 8)) + #.(char-code #\s))) + (:ft-glyph-format-outline + #.(logior (logior (logior (ash #.(char-code #\o) 24) (ash #.(char-code #\u) 16)) (ash #.(char-code #\t) 8)) + #.(char-code #\l))) + (:ft-glyph-format-plotter + #.(logior (logior (logior (ash #.(char-code #\p) 24) (ash #.(char-code #\l) 16)) (ash #.(char-code #\o) 8)) + #.(char-code #\t)))) + +(defcstruct freetype:span + (freetype:x :int16) (freetype:len :uint16) (freetype:coverage :uint8)) + +(defctype freetype:raster-span-func :pointer) + +(defctype freetype:raster-bit-test-func :pointer) + +(defctype freetype:raster-bit-set-func :pointer) + +(defcenum freetype:raster-flag + (:ft-raster-flag-default #.#o0) (:ft-raster-flag-aa #.1) (:ft-raster-flag-direct #.2) (:ft-raster-flag-clip #.4)) + +(defcstruct freetype:raster-params + (freetype:target (* freetype:bitmap)) (freetype:source :pointer) (freetype:flags :int32) + (freetype:gray-spans freetype:raster-span-func) (freetype:black-spans freetype:raster-span-func) + (freetype:bit-test freetype:raster-bit-test-func) (freetype:bit-set freetype:raster-bit-set-func) (freetype:user :pointer) + (freetype:clip-box freetype:bbox)) + +(defctype freetype:raster-new-func :pointer) + +(defctype freetype:raster-done-func :pointer) + +(defctype freetype:raster-reset-func :pointer) + +(defctype freetype:raster-set-mode-func :pointer) + +(defctype freetype:raster-render-func :pointer) + +(defcstruct freetype:raster-funcs + (freetype:glyph-format freetype:glyph-format) (freetype:raster-new freetype:raster-new-func) + (freetype:raster-reset freetype:raster-reset-func) (freetype:raster-set-mode freetype:raster-set-mode-func) + (freetype:raster-render freetype:raster-render-func) (freetype:raster-done freetype:raster-done-func)) + +(defcstruct freetype:unit-vector + (freetype:x freetype:f2dot14) (freetype:y freetype:f2dot14)) + +(defcstruct freetype:matrix + (freetype:xx freetype:fixed) (freetype:xy freetype:fixed) (freetype:yx freetype:fixed) + (freetype:yy freetype:fixed)) + +(defctype freetype:generic-finalizer :pointer) + +(defcstruct freetype:generic + (freetype:data :pointer) (freetype:finalizer freetype:generic-finalizer)) + +(defcstruct freetype:list-node-rec + (freetype:prev freetype:list-node) (freetype:next freetype:list-node) (freetype:data :pointer)) + +(defcstruct freetype:list-rec + (freetype:head freetype:list-node) (freetype:tail freetype:list-node)) + +(defcstruct freetype:glyph-metrics + (freetype:width freetype:pos) (freetype:height freetype:pos) + (freetype:hori-bearing-x freetype:pos) (freetype:hori-bearing-y freetype:pos) (freetype:hori-advance freetype:pos) + (freetype:vert-bearing-x freetype:pos) (freetype:vert-bearing-y freetype:pos) (freetype:vert-advance freetype:pos)) + +(defcstruct freetype:bitmap-size + (freetype:height freetype:short) (freetype:width freetype:short)) + +(defctype freetype:sub-glyph :pointer) +;; (struct freetype::sub-glyph-)) + +(defcstruct freetype:glyph-slot-rec + (freetype:library freetype:library) (freetype:face (* (struct freetype::face-rec-))) + (freetype:next (* (struct freetype::glyph-slot-rec-))) (freetype:flags freetype:uint) (freetype:generic freetype:generic) + (freetype:metrics freetype:glyph-metrics) (freetype:linear-hori-advance freetype:fixed) + (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) + (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) + (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) + (freetype:control-data :pointer) (freetype:control-len :long) (freetype:other :pointer) + (freetype:internal freetype:slot-internal)) + +(defcstruct freetype:size-metrics + (freetype:x-ppem freetype:ushort) (freetype:y-ppem freetype:ushort) + (freetype:x-scale freetype:fixed) (freetype:y-scale freetype:fixed) (freetype:ascender freetype:pos) + (freetype:descender freetype:pos) (freetype:height freetype:pos) (freetype:max-advance freetype:pos)) + +(defcstruct freetype:size-rec + (freetype:face (* (struct freetype::face-rec-))) (freetype:generic freetype:generic) + (freetype:metrics freetype:size-metrics) (freetype:internal freetype:size-internal)) + +(defcstruct freetype:face-rec + (freetype:num-faces freetype:long) (freetype:face-index freetype:long) + (freetype:face-flags freetype:long) (freetype:style-flags freetype:long) (freetype:num-glyphs freetype:long) + (freetype:family-name (* freetype:string)) (freetype:style-name (* freetype:string)) (freetype:num-fixed-sizes freetype:int) + (freetype:available-sizes (* freetype:bitmap-size)) (freetype:num-charmaps freetype:int) + (freetype:charmaps (* freetype:char-map)) (freetype:generic freetype:generic) (freetype:bbox freetype:bbox) + (freetype:units-per-em freetype:ushort) (freetype:ascender freetype:short) (freetype:descender freetype:short) + (freetype:height freetype:short) (freetype:max-advance-width freetype:short) (freetype:max-advance-height freetype:short) + (freetype:underline-position freetype:short) (freetype:underline-thickness freetype:short) + (freetype:glyph (* (struct freetype::glyph-slot-rec-))) + (freetype:size_s (* (struct freetype:size-rec))) (freetype:charmap freetype:char-map) + (freetype:driver freetype:driver) (freetype:memory freetype:memory) (freetype:stream freetype:stream) + (freetype:sizes-list freetype:list-rec) (freetype:autohint freetype:generic) (freetype:extensions :pointer) + (freetype:internal freetype:face-internal)) + +(defcstruct freetype:size-rec + (freetype:face (* freetype:face-rec)) + (freetype:generic freetype:generic) + (freetype:metrics freetype:size-metrics) + (freetype:internal freetype:size-internal)) + +(defcstruct freetype:glyph-slot-rec + (freetype:library freetype:library) (freetype:face (* freetype:face-rec)) + (freetype:next (* (struct freetype::glyph-slot-rec-))) (freetype:flags freetype:uint) (freetype:generic freetype:generic) + (freetype:metrics freetype:glyph-metrics) (freetype:linear-hori-advance freetype:fixed) + (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) + (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) + (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) + (freetype:control-data :pointer) (freetype:control-len :long) (freetype:other :pointer) + (freetype:internal freetype:slot-internal)) + +(define-alien-type freetype:glyph-slot (* freetype:glyph-slot-rec)) +(define-alien-type freetype:size (* freetype:size-rec)) + +(define-alien-routine ("FT_Init_FreeType" freetype:init-free-type) freetype:error (freetype::alibrary (* freetype:library))) + +(define-alien-routine ("FT_Done_FreeType" freetype:done-free-type) freetype:error (freetype:library freetype:library)) + +(defcenum freetype:open-flags + (:ft-open-memory #.1) (:ft-open-stream #.2) (:ft-open-pathname #.4) (:ft-open-driver #.8) (:ft-open-params #.16)) + +(defcstruct freetype:parameter (freetype:tag freetype:ulong) (freetype:data freetype:pointer)) + +(defcstruct freetype:open-args + (freetype:flags freetype:open-flags) (freetype:memory-base (* freetype:byte)) + (freetype:memory-size freetype:long) (freetype:pathname (* freetype:string)) (freetype:stream freetype:stream) + (freetype:driver freetype:module) (freetype:num-params freetype:int) (freetype:params (* freetype:parameter))) + +(define-alien-routine ("FT_New_Face" freetype:new-face) freetype:error + (freetype:library freetype:library) + (freetype::filepathname :string) + (freetype::face_index freetype:long) + ;; this is a pointer to a pointer to a face-rec... + (freetype::aface (* (* freetype:face-rec)))) + +(define-alien-routine ("FT_New_Memory_Face" freetype:new-memory-face) freetype:error (freetype:library freetype:library) + (freetype::file_base (* freetype:byte)) (freetype::file_size freetype:long) (freetype::face_index freetype:long) + (freetype::aface (* freetype:face))) + +(define-alien-routine ("FT_Open_Face" freetype:open-face) freetype:error (freetype:library freetype:library) + (freetype::args (* freetype:open-args)) (freetype::face_index freetype:long) (freetype::aface (* freetype:face))) + +(define-alien-routine ("FT_Attach_File" freetype:attach-file) freetype:error (freetype:face freetype:face) + (freetype::filepathname (* :int8))) + +(define-alien-routine ("FT_Attach_Stream" freetype:attach-stream) freetype:error (freetype:face freetype:face) + (freetype::parameters (* freetype:open-args))) + +(define-alien-routine ("FT_Done_Face" freetype:done-face) freetype:error (freetype:face freetype:face)) + +(define-alien-routine ("FT_Set_Char_Size" freetype:set-char-size) freetype:error (freetype:face freetype:face) + (freetype::char_width freetype:f26dot6) (freetype::char_height freetype:f26dot6) (freetype::horz_resolution freetype:uint) + (freetype::vert_resolution freetype:uint)) + +(define-alien-routine ("FT_Set_Pixel_Sizes" freetype:set-pixel-sizes) freetype:error (freetype:face freetype:face) + (freetype::pixel_width freetype:uint) (freetype::pixel_height freetype:uint)) + +(define-alien-routine ("FT_Load_Glyph" freetype:load-glyph) freetype:error (freetype:face freetype:face) + (freetype::glyph_index freetype:uint) (freetype::load_flags freetype:int)) + +(define-alien-routine ("FT_Load_Char" freetype:load-char) freetype:error (freetype:face freetype:face) + (freetype::char_code freetype:ulong) (freetype::load_flags freetype:int)) + +(define-alien-routine ("FT_Set_Transform" freetype:set-transform) :void (freetype:face freetype:face) + (freetype:matrix (* freetype:matrix)) (freetype:delta (* freetype:vector))) + +(defcenum freetype:render-mode + (:ft-render-mode-normal #.#o0) (:ft-render-mode-mono #.1)) + +(define-alien-routine ("FT_Render_Glyph" freetype:render-glyph) freetype:error (freetype::slot freetype:glyph-slot) + (freetype::render_mode freetype:uint)) + +(defcenum freetype::kerning-mode- + (:ft-kerning-default #.#o0) :ft-kerning-unfitted :ft-kerning-unscaled) + +(define-alien-routine ("FT_Get_Kerning" freetype:get-kerning) freetype:error (freetype:face freetype:face) + (freetype::left_glyph freetype:uint) (freetype::right_glyph freetype:uint) (freetype::kern_mode freetype:uint) + (freetype::akerning (* freetype:vector))) + +(define-alien-routine ("FT_Get_Glyph_Name" freetype:get-glyph-name) freetype:error (freetype:face freetype:face) + (freetype::glyph_index freetype:uint) (freetype:buffer freetype:pointer) (freetype::buffer_max freetype:uint)) + +(define-alien-routine ("FT_Get_Char_Index" freetype:get-char-index) freetype:uint (freetype:face freetype:face) + (freetype::charcode freetype:ulong)) + +(define-alien-routine ("FT_MulDiv" freetype:mul-div) freetype:long (freetype::a freetype:long) (freetype::b freetype:long) + (freetype::c freetype:long)) + +(define-alien-routine ("FT_MulFix" freetype:mul-fix) freetype:long (freetype::a freetype:long) (freetype::b freetype:long)) + +(define-alien-routine ("FT_DivFix" freetype:div-fix) freetype:long (freetype::a freetype:long) (freetype::b freetype:long)) + +(define-alien-routine ("FT_RoundFix" freetype:round-fix) freetype:fixed (freetype::a freetype:fixed)) + +(define-alien-routine ("FT_CeilFix" freetype:ceil-fix) freetype:fixed (freetype::a freetype:fixed)) + +(define-alien-routine ("FT_FloorFix" freetype:floor-fix) freetype:fixed (freetype::a freetype:fixed)) + +(define-alien-routine ("FT_Vector_Transform" freetype:vector-transform) :void (freetype::vec (* freetype:vector)) + (freetype:matrix (* freetype:matrix))) + +(defcenum freetype:encoding + (:ft-encoding-none #.(logior (logior (logior (ash #o0 24) (ash #o0 16)) (ash #o0 8)) #o0)) + (:ft-encoding-symbol + #.(logior (logior (logior (ash #.(char-code #\s) 24) (ash #.(char-code #\y) 16)) (ash #.(char-code #\m) 8)) + #.(char-code #\b))) + (:ft-encoding-unicode + #.(logior (logior (logior (ash #.(char-code #\u) 24) (ash #.(char-code #\n) 16)) (ash #.(char-code #\i) 8)) + #.(char-code #\c))) + (:ft-encoding-latin-2 + #.(logior (logior (logior (ash #.(char-code #\l) 24) (ash #.(char-code #\a) 16)) (ash #.(char-code #\t) 8)) + #.(char-code #\2))) + (:ft-encoding-sjis + #.(logior (logior (logior (ash #.(char-code #\s) 24) (ash #.(char-code #\j) 16)) (ash #.(char-code #\i) 8)) + #.(char-code #\s))) + (:ft-encoding-gb2312 + #.(logior (logior (logior (ash #.(char-code #\g) 24) (ash #.(char-code #\b) 16)) (ash #.(char-code #\ ) 8)) + #.(char-code #\ ))) + (:ft-encoding-big5 + #.(logior (logior (logior (ash #.(char-code #\b) 24) (ash #.(char-code #\i) 16)) (ash #.(char-code #\g) 8)) + #.(char-code #\5))) + (:ft-encoding-wansung + #.(logior (logior (logior (ash #.(char-code #\w) 24) (ash #.(char-code #\a) 16)) (ash #.(char-code #\n) 8)) + #.(char-code #\s))) + (:ft-encoding-johab + #.(logior (logior (logior (ash #.(char-code #\j) 24) (ash #.(char-code #\o) 16)) (ash #.(char-code #\h) 8)) + #.(char-code #\a))) + (:ft-encoding-adobe-standard + #.(logior (logior (logior (ash #.(char-code #\A) 24) (ash #.(char-code #\D) 16)) (ash #.(char-code #\O) 8)) + #.(char-code #\B))) + (:ft-encoding-adobe-expert + #.(logior (logior (logior (ash #.(char-code #\A) 24) (ash #.(char-code #\D) 16)) (ash #.(char-code #\B) 8)) + #.(char-code #\E))) + (:ft-encoding-adobe-custom + #.(logior (logior (logior (ash #.(char-code #\A) 24) (ash #.(char-code #\D) 16)) (ash #.(char-code #\B) 8)) + #.(char-code #\C))) + (:ft-encoding-apple-roman + #.(logior (logior (logior (ash #.(char-code #\a) 24) (ash #.(char-code #\r) 16)) (ash #.(char-code #\m) 8)) + #.(char-code #\n)))) + +#| +(define-alien-type freetype:char-map-rec + (struct freetype::char-map-rec- (freetype:face freetype:face) (freetype:encoding freetype:encoding) + (freetype:platform-id freetype:ushort) (freetype:encoding-id freetype:ushort))) +|# + +(define-alien-routine ("FT_Select_Charmap" freetype:select-charmap) freetype:error (freetype:face freetype:face) + (freetype:encoding freetype:encoding)) + +(define-alien-routine ("FT_Set_Charmap" freetype:set-charmap) freetype:error (freetype:face freetype:face) (freetype:charmap freetype:char-map)) diff --git a/Experimental/freetype/freetype-fonts-cffi.lisp b/Experimental/freetype/freetype-fonts-cffi.lisp new file mode 100644 index 00000000..afe884c9 --- /dev/null +++ b/Experimental/freetype/freetype-fonts-cffi.lisp @@ -0,0 +1,635 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: MCCLIM-FREETYPE; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Experimental FreeType support +;;; Created: 2003-05-25 16:32 +;;; Author: Gilbert Baumann +;;; License: LGPL (See file COPYING for details). +;;; --------------------------------------------------------------------------- +;;; (c) copyright 2003 by Gilbert Baumann + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. + +(in-package :MCCLIM-FREETYPE) + +;;; reset safety up to 3 to try to work out some of my problems. If +;;; this gets fixed, presumably it should be dropped back down to +;;; 1... [2006/05/24:rpg] +(declaim (optimize (speed 3) (safety 3) (debug 3) (space 3))) + +;;;; Notes + +;; You might need to tweak mcclim-freetype::*families/faces* to point +;; to where ever there are suitable TTF fonts on your system. + +(defclass vague-font () + ((lib :initarg :lib) + (filename :initarg :filename))) + +(defparameter *vague-font-hash* (make-hash-table :test #'equal)) + +(defun make-vague-font (filename) + (let ((val (gethash filename *vague-font-hash*))) + (or val + (setf (gethash filename *vague-font-hash*) + (make-instance 'vague-font + :lib + ;; I am not at all sure that this is the + ;; right translation --- because of the + ;; difference between SBCL aliens and + ;; CFFI, I'm not sure what the deref was + ;; intended to achieve... [2006/05/24:rpg] + (let ((libf (cffi:foreign-alloc 'freetype:library))) + (freetype:init-free-type libf) + (cffi:mem-aref libf 'freetype:library)) +;;; (let ((libf (make-alien freetype:library))) +;;; (declare (type (alien (* freetype:library)) libf)) +;;; (freetype:init-free-type libf) +;;; (deref libf)) + :filename filename))))) + +(defparameter *dpi* 72) + +(defparameter *concrete-font-hash* (make-hash-table :test #'equal)) + +(defun make-concrete-font (vague-font size &key (dpi *dpi*)) + (with-slots (lib filename) vague-font + (let* ((key (cons lib filename)) + (val (gethash key *concrete-font-hash*))) + (unless val + (let ((facef + ;; this will allocate a pointer (notionally to a + ;; face-rec), and return a pointer to it (the pointer). + (foreign-alloc 'freetype:face) + ;;(make-alien freetype:face)) + )) + ;;(declare (type (alien (* freetype:face)) facef)) + (if (zerop (freetype:new-face lib filename 0 facef)) + (setf val (setf (gethash key *concrete-font-hash*) + (cffi:mem-ref facef 'freetype:face))) + +;;; (setf val (setf (gethash key *concrete-font-hash*) +;;; (deref facef))) + (error "Freetype error in make-concrete-font")))) + (let ((face val)) + ;; (declare (type (alien freetype:face) face)) + (freetype:set-char-size face 0 (round (* size 64)) (round dpi) (round dpi)) + face)))) + +(declaim (inline make-concrete-font)) + +(defun glyph-pixarray (face char) +;;; (declare (optimize (speed 3) (debug 1)) +;;; (inline freetype:load-glyph freetype:render-glyph) +;;; (type (alien freetype:face) face)) + (freetype:load-glyph face (freetype:get-char-index face (char-code char)) 0) + (freetype:render-glyph (foreign-slot-value face 'freetype:face-rec 'freetype:glyph) 0) + (with-foreign-slots ((glyph) face freetype:face-rec) + (with-foreign-slots ((bitmap) glyph freetype:glyph-slot-rec) + (with-foreign-slots ((width pitch rows buffer) bitmap freetype:bitmap) + (let ((res + (make-array (list rows width) + :element-type '(unsigned-byte 8)))) +;;; (let* ((width (slot bm 'freetype:width)) +;;; (pitch (slot bm 'freetype:pitch)) +;;; (height (slot bm 'freetype:rows)) +;;; (buffer (slot bm 'freetype:buffer)) +;;; (res (make-array (list height width) :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8) (* *)) res)) + (let ((m (* width rows))) + (locally + (declare (optimize (speed 3) (safety 0))) + (loop for y*width of-type fixnum below m by width + for y*pitch of-type fixnum from 0 by pitch do + (loop for x of-type fixnum below width do + (setf (row-major-aref res (+ x y*width)) + (cffi:mem-aref buffer :uint8 (+ x y*pitch)) + ;; (deref buffer (+ x y*pitch)) + ))))) + (with-foreign-slots ((bitmap-left + bitmap-top + advance) glyph freetype:glyph-slot-rec) + (with-foreign-slots ((x y) advance freetype:vector) + (values + res + bitmap-left + ;; (slot glyph 'freetype:bitmap-left) + bitmap-top + ;;(slot glyph 'freetype:bitmap-top) + (/ x 64) + ;;(/ (slot (slot glyph 'freetype:advance) 'freetype:x) 64) + (/ y 64) + ;;(/ (slot (slot glyph 'freetype:advance) 'freetype:y) 64) + ) + ))))))) + +(defun glyph-advance (face char) + ;; I believe that face is a pointer to a face-rec... + ;; note that we're not catching error result here... + (freetype:load-glyph face (freetype:get-char-index face (char-code char)) 0) + (let* ((glyph (foreign-slot-value face 'freetype:face-rec 'freetype:glyph))) + ;;; glyph will be a glyph-slot-rec... + (with-foreign-slots ((advance) glyph freetype:glyph-slot-rec) + (with-foreign-slots ((x y) advance freetype:vector) + (values + (/ x 64) + (/ y 64)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun display-glyph-cache (display) + (or (getf (xlib:display-plist display) 'glyph-cache) + (setf (getf (xlib:display-plist display) 'glyph-cache) + (make-hash-table :test #'equalp)))) + +(defun display-the-glyph-set (display) + (or (getf (xlib:display-plist display) 'the-glyph-set) + (setf (getf (xlib:display-plist display) 'the-glyph-set) + (xlib::render-create-glyph-set + (first (xlib::find-matching-picture-formats display + :alpha 8 :red 0 :green 0 :blue 0)))))) + +(defun display-free-glyph-ids (display) + (getf (xlib:display-plist display) 'free-glyph-ids)) + +(defun (setf display-free-glyph-ids) (new-value display) + (setf (getf (xlib:display-plist display) 'free-glyph-ids) new-value)) + +(defun display-free-glyph-id-counter (display) + (getf (xlib:display-plist display) 'free-glyph-id-counter 0)) + +(defun (setf display-free-glyph-id-counter) (new-value display) + (setf (getf (xlib:display-plist display) 'free-glyph-id-counter) new-value)) + +(defun display-draw-glyph-id (display) + (or (pop (display-free-glyph-ids display)) + (incf (display-free-glyph-id-counter display)))) + +(defun display-get-glyph (display font matrix glyph-index) + (or (gethash (list font matrix glyph-index) (display-glyph-cache display)) + (setf (gethash (list font matrix glyph-index) (display-glyph-cache display)) + (display-generate-glyph display font matrix glyph-index)))) + +(defvar *font-hash* + (make-hash-table :test #'equalp)) + +(defun display-generate-glyph (display font matrix glyph-index) + (let* ((glyph-id (display-draw-glyph-id display)) + (font (or (gethash font *font-hash*) + (setf (gethash font *font-hash*) + (make-vague-font font)))) + (face (make-concrete-font font matrix))) + (multiple-value-bind (arr left top dx dy) (glyph-pixarray face (code-char glyph-index)) + (when (= (array-dimension arr 0) 0) + (setf arr (make-array (list 1 1) :element-type '(unsigned-byte 8) :initial-element 0))) + (xlib::render-add-glyph (display-the-glyph-set display) glyph-id + :data arr + :x-origin (- left) + :y-origin top + :x-advance dx + :y-advance dy) + (let ((right (+ left (array-dimension arr 1)))) + (list glyph-id dx dy left right top))))) + +;;;;;;; mcclim interface + +(defclass freetype-face () + ((display :initarg :display) + (font :initarg :font) + (matrix :initarg :matrix) + (ascent :initarg :ascent) + (descent :initarg :descent))) + +(defmethod clim-clx::font-ascent ((font freetype-face)) + (with-slots (ascent) font + ascent)) + +(defmethod clim-clx::font-descent ((font freetype-face)) + (with-slots (descent) font + descent)) + +(defmethod clim-clx::font-glyph-width ((font freetype-face) char) + (with-slots (display font matrix) font + (nth 1 (display-get-glyph display font matrix char)))) +(defmethod clim-clx::font-glyph-left ((font freetype-face) char) + (with-slots (display font matrix) font + (nth 3 (display-get-glyph display font matrix char)))) +(defmethod clim-clx::font-glyph-right ((font freetype-face) char) + (with-slots (display font matrix) font + (nth 4 (display-get-glyph display font matrix char)))) + +;;; this is a hacky copy of XLIB:TEXT-EXTENTS +(defmethod clim-clx::font-text-extents ((font freetype-face) string + &key (start 0) (end (length string)) translate) + ;; -> (width ascent descent left right + ;; font-ascent font-descent direction + ;; first-not-done) + translate + (let ((width (loop for i from start below end + sum (clim-clx::font-glyph-width font (char-code (aref string i)))))) + (values + width + (clim-clx::font-ascent font) + (clim-clx::font-descent font) + (clim-clx::font-glyph-left font (char-code (char string start))) + (- width (- (clim-clx::font-glyph-width font (char-code (char string (1- end)))) + (clim-clx::font-glyph-right font (char-code (char string (1- end)))))) + (clim-clx::font-ascent font) + (clim-clx::font-descent font) + 0 end))) + +(defun drawable-picture (drawable) + (or (getf (xlib:drawable-plist drawable) 'picture) + (setf (getf (xlib:drawable-plist drawable) 'picture) + (xlib::render-create-picture drawable + :format + (xlib::find-window-picture-format + (xlib:drawable-root drawable)))))) + +(defun gcontext-picture (drawable gcontext) + (or (getf (xlib:gcontext-plist gcontext) 'picture) + (setf (getf (xlib:gcontext-plist gcontext) 'picture) + (let ((pixmap (xlib:create-pixmap :drawable drawable + :depth (xlib:drawable-depth drawable) + :width 1 :height 1))) + (list + (xlib::render-create-picture + pixmap + :format (xlib::find-window-picture-format (xlib:drawable-root drawable)) + :repeat :on) + pixmap))))) + +(defmethod clim-clx::font-draw-glyphs ((font freetype-face) mirror gc x y string &key start end translate) + (declare (ignore translate)) + (let ((display (xlib:drawable-display mirror))) + (with-slots (font matrix) font + (destructuring-bind (source-picture source-pixmap) + (gcontext-picture mirror gc) + (declare (ignore source-pixmap)) + (let ((fg (xlib:gcontext-foreground gc))) + (xlib::render-fill-rectangle source-picture + :src + (list (ash (ldb (byte 8 16) fg) 8) + (ash (ldb (byte 8 8) fg) 8) + (ash (ldb (byte 8 0) fg) 8) + #xFFFF) + 0 0 1 1)) + (setf (xlib::picture-clip-mask (drawable-picture mirror)) + (xlib::gcontext-clip-mask gc)) + (xlib::render-composite-glyphs + (drawable-picture mirror) + (display-the-glyph-set display) + source-picture + x y + (map 'vector (lambda (x) + (first + (display-get-glyph display font matrix (char-code x)))) + (subseq string start end))))))) + +(let ((cache (make-hash-table :test #'equal))) + (defun make-free-type-face (display font size) + (or (gethash (list display font size) cache) + (setf (gethash (list display font size) cache) + (let* ((f.font (or (gethash font *font-hash*) + (setf (gethash font *font-hash*) + (make-vague-font font)))) + (f (make-concrete-font f.font size))) + (with-foreign-slots ((size_s) f freetype:face-rec) + (with-foreign-slots ((metrics) size_s freetype:size-rec) + (with-foreign-slots ((ascender descender) metrics freetype:size-metrics) + (make-instance 'freetype-face + :display display + :font font + :matrix size + :ascent (/ ascender 64) + :descent (/ descender -64)))))))))) + +(defparameter *sizes* + '(:normal 12 + :small 10 + :very-small 8 + :tiny 8 + :large 14 + :very-large 18 + :huge 24)) + +(defparameter *families/faces* + '(((:fix :roman) . "VeraMono.ttf") + ((:fix :italic) . "VeraMoIt.ttf") + ((:fix (:bold :italic)) . "VeraMoBI.ttf") + ((:fix (:italic :bold)) . "VeraMoBI.ttf") + ((:fix :bold) . "VeraMoBd.ttf") + ((:serif :roman) . "VeraSe.ttf") + ((:serif :italic) . "VeraSe.ttf") + ((:serif (:bold :italic)) . "VeraSeBd.ttf") + ((:serif (:italic :bold)) . "VeraSeBd.ttf") + ((:serif :bold) . "VeraSeBd.ttf") + ((:sans-serif :roman) . "Vera.ttf") + ((:sans-serif :italic) . "VeraIt.ttf") + ((:sans-serif (:bold :italic)) . "VeraBI.ttf") + ((:sans-serif (:italic :bold)) . "VeraBI.ttf") + ((:sans-serif :bold) . "VeraBd.ttf"))) + +(defvar *freetype-font-path*) + +(fmakunbound 'clim-clx::text-style-to-x-font) + +(defstruct freetype-device-font-name + (font-file (error "missing argument")) + (size (error "missing argument"))) + +(defmethod clim-clx::text-style-to-X-font :around + ((port clim-clx::clx-port) (text-style climi::device-font-text-style)) + (let ((display (slot-value port 'clim-clx::display)) + (font-name (climi::device-font-name text-style))) + (make-free-type-face display + (freetype-device-font-name-font-file font-name) + (freetype-device-font-name-size font-name)))) + +(defmethod text-style-mapping :around + ((port clim-clx::clx-port) (text-style climi::device-font-text-style) + &optional character-set) + (declare (ignore character-set)) + (values (gethash text-style (clim-clx::port-text-style-mappings port)))) + +(defmethod (setf text-style-mapping) :around + (value + (port clim-clx::clx-port) + (text-style climi::device-font-text-style) + &optional character-set) + (declare (ignore character-set)) + (setf (gethash text-style (clim-clx::port-text-style-mappings port)) value)) + +(defparameter *free-type-face-hash* (make-hash-table :test #'equal)) + +(defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) (text-style standard-text-style)) + (multiple-value-bind (family face size) + (clim:text-style-components text-style) + (let ((display (clim-clx::clx-port-display port))) + (setf face (or face :roman)) + (setf size (or size :normal)) + (cond (size + (setf size (getf *sizes* size size)) + (let ((val (gethash (list display family face size) *free-type-face-hash*))) + (if val val + (setf (gethash (list display family face size) *free-type-face-hash*) + (let* ((font-path-relative (cdr (assoc (list family face) *families/faces* + :test #'equal))) + (font-path (namestring (merge-pathnames font-path-relative *freetype-font-path*)))) + (if (and font-path (probe-file font-path)) + (make-free-type-face display font-path size) + (call-next-method))))))) + (t + (call-next-method)))))) + +(defmethod clim-clx::text-style-to-X-font ((port clim-clx::clx-port) text-style) + ;; ok, this isn't the most helpful error message... [2006/05/24:rpg] + (error "You lost: ~S." text-style)) + +;;;;;; + +(in-package :clim-clx) + +(defmethod text-style-ascent (text-style (medium clx-medium)) + (let ((font (text-style-to-X-font (port medium) text-style))) + (clim-clx::font-ascent font))) + +(defmethod text-style-descent (text-style (medium clx-medium)) + (let ((font (text-style-to-X-font (port medium) text-style))) + (clim-clx::font-descent font))) + +(defmethod text-style-height (text-style (medium clx-medium)) + (let ((font (text-style-to-X-font (port medium) text-style))) + (+ (clim-clx::font-ascent font) (clim-clx::font-descent font)))) + +(defmethod text-style-character-width (text-style (medium clx-medium) char) + (clim-clx::font-glyph-width (text-style-to-X-font (port medium) text-style) (char-code char))) + +(defmethod text-style-width (text-style (medium clx-medium)) + (text-style-character-width text-style medium #\m)) + +(defmethod text-size ((medium clx-medium) string &key text-style (start 0) end) + (when (characterp string) + (setf string (make-string 1 :initial-element string))) + (unless end (setf end (length string))) + (unless text-style (setf text-style (medium-text-style medium))) + (let ((xfont (text-style-to-X-font (port medium) text-style))) + (cond ((= start end) + (values 0 0 0 0 0)) + (t + (let ((position-newline (position #\newline string :start start))) + (cond ((not (null position-newline)) + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (font-text-extents xfont string + :start start :end position-newline + :translate #'translate) + (declare (ignorable left right + font-ascent font-descent + direction first-not-done)) + (multiple-value-bind (w h x y baseline) + (text-size medium string :text-style text-style + :start (1+ position-newline) :end end) + (values (max w width) (+ ascent descent h) + x (+ ascent descent y) (+ ascent descent baseline))))) + (t + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (font-text-extents xfont string + :start start :end end + :translate #'translate) + (declare (ignorable left right + font-ascent font-descent + direction first-not-done)) + (values width (+ ascent descent) width 0 ascent)) )))))) ) + +(defmethod climi::text-bounding-rectangle* + ((medium clx-medium) string &key text-style (start 0) end) + (when (characterp string) + (setf string (make-string 1 :initial-element string))) + (unless end (setf end (length string))) + (unless text-style (setf text-style (medium-text-style medium))) + (let ((xfont (text-style-to-X-font (port medium) text-style))) + (cond ((= start end) + (values 0 0 0 0)) + (t + (let ((position-newline (position #\newline string :start start))) + (cond ((not (null position-newline)) + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (font-text-extents xfont string + :start start :end position-newline + :translate #'translate) + (declare (ignorable left right + font-ascent font-descent + direction first-not-done) + (ignore width)) + (multiple-value-bind (minx miny maxx maxy) + (climi::text-bounding-rectangle* + medium string :text-style text-style + :start (1+ position-newline) :end end) + (declare (ignore miny)) + (values (min minx left) (- ascent) + (max maxx right) (+ descent maxy))))) + (t + (multiple-value-bind (width ascent descent left right + font-ascent font-descent direction + first-not-done) + (font-text-extents xfont string + :start start :end end + :translate #'translate) + (declare (ignore width direction first-not-done + descent ascent)) + ;; FIXME: Potential style points: + ;; * (min 0 left), (max width right) + ;; * font-ascent / ascent + (values left (- font-ascent) right font-descent))))))))) + + +(defmethod make-medium-gcontext* (medium foreground background line-style text-style (ink color) clipping-region) + (declare (ignore clipping-region line-style background foreground)) + (let* ((drawable (sheet-mirror (medium-sheet medium))) + (port (port medium))) + (let ((gc (xlib:create-gcontext :drawable drawable))) + (Let ((fn (text-style-to-X-font port text-style))) + (if (typep fn 'xlib:font) + (setf (xlib:gcontext-font gc) fn))) + (setf + (xlib:gcontext-foreground gc) (X-pixel port ink) + ) + gc))) + +(defmethod medium-draw-text* ((medium clx-medium) string x y + start end + align-x align-y + toward-x toward-y transform-glyphs) + (declare (ignore toward-x toward-y transform-glyphs)) + (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) + x y) + (with-clx-graphics (medium) + (when (characterp string) + (setq string (make-string 1 :initial-element string))) + (when (null end) (setq end (length string))) + (multiple-value-bind (text-width text-height x-cursor y-cursor baseline) + (text-size medium string :start start :end end) + (declare (ignore x-cursor y-cursor)) + (unless (and (eq align-x :left) (eq align-y :baseline)) + (setq x (- x (ecase align-x + (:left 0) + (:center (round text-width 2)) + (:right text-width)))) + (setq y (ecase align-y + (:top (+ y baseline)) + (:center (+ y baseline (- (floor text-height 2)))) + (:baseline y) + (:bottom (+ y baseline (- text-height))))))) + (let ((x (round-coordinate x)) + (y (round-coordinate y))) + (when (and (<= #x-8000 x #x7FFF) + (<= #x-8000 y #x7FFF)) + (multiple-value-bind (halt width) + (font-draw-glyphs + (text-style-to-X-font (port medium) (medium-text-style medium)) + mirror gc x y string + :start start :end end + :translate #'translate))))))) + + +(defmethod (setf medium-text-style) :before (text-style (medium clx-medium)) + (with-slots (gc) medium + (when gc + (let ((old-text-style (medium-text-style medium))) + (unless (eq text-style old-text-style) + (let ((fn (text-style-to-X-font (port medium) (medium-text-style medium)))) + (when (typep fn 'xlib:font) + (setf (xlib:gcontext-font gc) + fn)))))))) + +(defmethod medium-gcontext ((medium clx-medium) (ink color)) + (let* ((port (port medium)) + (mirror (port-lookup-mirror port (medium-sheet medium))) + (line-style (medium-line-style medium))) + (with-slots (gc) medium + (unless gc + (setq gc (xlib:create-gcontext :drawable mirror)) + ;; this is kind of false, since the :unit should be taken + ;; into account -RS 2001-08-24 + (setf (xlib:gcontext-line-width gc) (line-style-thickness line-style) + (xlib:gcontext-cap-style gc) (line-style-cap-shape line-style) + (xlib:gcontext-join-style gc) (line-style-joint-shape line-style)) + (let ((dashes (line-style-dashes line-style))) + (unless (null dashes) + (setf (xlib:gcontext-line-style gc) :dash + (xlib:gcontext-dashes gc) (if (eq dashes t) 3 + dashes))))) + (setf (xlib:gcontext-function gc) boole-1) + (let ((fn (text-style-to-X-font port (medium-text-style medium)))) + (when (typep fn 'xlib:font) + (setf (xlib:gcontext-font gc) fn))) + (setf (xlib:gcontext-foreground gc) (X-pixel port ink) + (xlib:gcontext-background gc) (X-pixel port (medium-background medium))) + ;; Here is a bug with regard to clipping ... ;-( --GB ) + #-nil ; being fixed at the moment, a bit twitchy though -- BTS + (let ((clipping-region (medium-device-region medium))) + (if (region-equal clipping-region +nowhere+) + (setf (xlib:gcontext-clip-mask gc) #()) + (let ((rect-seq (clipping-region->rect-seq clipping-region))) + (when rect-seq + #+nil + ;; ok, what McCLIM is generating is not :yx-banded... + ;; (currently at least) + (setf (xlib:gcontext-clip-mask gc :yx-banded) rect-seq) + #-nil + ;; the region code doesn't support yx-banding... + ;; or does it? what does y-banding mean in this implementation? + ;; well, apparantly it doesn't mean what y-sorted means + ;; to clx :] we stick with :unsorted until that can be sorted out + (setf (xlib:gcontext-clip-mask gc :unsorted) rect-seq))))) + gc))) + +;;; +;;; This fixes the worst offenders making the assumption that drawing +;;; would be idempotent. +;;; + +(defmethod clim:handle-repaint :around ((s clim:sheet-with-medium-mixin) r) + (let ((m (clim:sheet-medium s)) + (r (clim:bounding-rectangle + (clim:region-intersection r (clim:sheet-region s))))) + (unless (eql r clim:+nowhere+) + (clim:with-drawing-options (m :clipping-region r) + (clim:draw-design m r :ink clim:+background-ink+) + (call-next-method s r))))) + + +;;;--------------------------------------------------------------------------- +;;; compiler warnings +;;;--------------------------------------------------------------------------- +#| +; While compiling (METHOD CLIM-INTERNALS::TEXT-BOUNDING-RECTANGLE* (CLX-MEDIUM T)): +Warning: Variable MINY is never used. +Warning: Variable WIDTH is never used. +; While compiling (METHOD MAKE-MEDIUM-GCONTEXT* (T T T T T COLOR T)): +Warning: Variable CLIPPING-REGION is never used. +Warning: Variable LINE-STYLE is never used. +Warning: Variable BACKGROUND is never used. +Warning: Variable FOREGROUND is never used. +; While compiling (METHOD MEDIUM-DRAW-TEXT* (CLX-MEDIUM T T T T T T T T T T)): +Warning: Variable WIDTH is never used. +Warning: Variable HALT is never used. +|# \ No newline at end of file diff --git a/Experimental/freetype/freetype-package-cffi.lisp b/Experimental/freetype/freetype-package-cffi.lisp new file mode 100644 index 00000000..7e400ebc --- /dev/null +++ b/Experimental/freetype/freetype-package-cffi.lisp @@ -0,0 +1,82 @@ +;;;--------------------------------------------------------------------------- +;;; Moved this here to make loading more convenient for the way I edit +;;; code [2006/05/23:rpg] +;;;--------------------------------------------------------------------------- +(DEFPACKAGE :FREETYPE + (:import-from :cffi #:define-foreign-library + #:use-foreign-library + #:defctype + #:defcenum + ;;#:defcstruct + #:defcunion + #:defcfun + ) + (:USE :cl +;;; #+sbcl :sb-alien +;;; #+(or cmu scl) :alien #+(or cmu scl) :c-call + ) + (:EXPORT "MEMORY-BASE" "DESCENDER" "LINEAR-VERT-ADVANCE" "YX" "XX" "FREE" "AVAILABLE-SIZES" "COVERAGE" "METRICS" + "RASTER-FLAG" "GLYPH" "GET-CHAR-INDEX" "LIMIT" "STRING" "SHIFT" "LEN" "UNDERLINE-POSITION" "RASTER-NEW-FUNC" + "POINTS" "TAG" "SIZE-INTERNAL" "NUM-SUBGLYPHS" "UNITS-PER-EM" "LIBRARY" "ALLOC" "OPEN-FACE" "ATTACH-FILE" + "BITMAP-TOP" "CURSOR" "BITMAP-LEFT" "MODULE" "PIXEL-MODE" "FREE-FUNC" "PITCH" "EXTENSIONS" "RASTER-RENDER-FUNC" + "GET-KERNING" "UFWORD" "OPEN-ARGS" "RASTER-FUNCS" "INT32" "PREV" "LOAD-CHAR" "PATHNAME" "HORI-BEARING-Y" + "RASTER-RENDER" "ENCODING" "OUTLINE-CONIC-TO-FUNC" "STREAM" "RASTER-RESET" "MOVE-TO" "GENERIC" "ATTACH-STREAM" + "Y-MAX" "X-MAX" "FACE-INDEX" "SUBGLYPHS" "BITMAP" "BITMAP-SIZE" "ADVANCE" "MUL-FIX" "SET-PIXEL-SIZES" + "OUTLINE-CUBIC-TO-FUNC" "FACE-INTERNAL" "WCHAR-T" "BLACK-SPANS" "TAGS" "N-CONTOURS" "YY" "XY" "CONIC-TO" "INT" + "UNDERLINE-THICKNESS" "NUM-FACES" "Y-PPEM" "X-PPEM" "PLATFORM-ID" "ASCENDER" "DIV-FIX" "USHORT" "WINT-T" + "CONTROL-LEN" "WIDTH" "NEW-FACE" "CHAR-MAP-REC" "Y-SCALE" "X-SCALE" "ALLOC-FUNC" "OUTLINE-FUNCS" "RASTER-DONE" + "UINT16" "FINALIZER" "RENDER-GLYPH" "GLYPH-METRICS" "RASTER-SPAN-FUNC" "CONTOURS" "GLYPH-SLOT-REC" + "VERT-BEARING-Y" "INIT-FREE-TYPE" "CLIP-BOX" "RASTER-RESET-FUNC" "FLAGS" "USER" "MEMORY-SIZE" "HEIGHT" "N-POINTS" + "UINT" "VECTOR" "NEXT" "LIST" "MEMORY" "BUFFER" "MUL-DIV" "PARAMS" "GET-GLYPH-NAME" "PTRDIFF-T" "CHAR-MAP" "FWORD" + "OUTLINE-MOVE-TO-FUNC" "STREAM-CLOSE" "SET-TRANSFORM" "FLOOR-FIX" "GLYPH-FORMAT" "GLYPH-SLOT" "KERNING-MODE" + "INT16" "POS" "FAST" "CONTROL-DATA" "NUM-PARAMS" "STYLE-FLAGS" "CHARMAP" "OUTLINE-LINE-TO-FUNC" "SELECT-CHARMAP" + "TARGET" "TAIL" "SLOT-INTERNAL" "OUTLINE-FLAGS" "RASTER-SET-MODE" "LIST-NODE" "NEW-MEMORY-FACE" "SIZE-REC" + "RASTER-DONE-FUNC" "HORI-ADVANCE" "RASTER" "REALLOC-FUNC" "READ" "ROUND-FIX" "LIST-REC" "UINT32" "ULONG" "HEAD" + "DRIVER" "MAX-ADVANCE-HEIGHT" "SIZE-T" "Y-MIN" "X-MIN" "RASTER-SET-MODE-FUNC" "SIZE-METRICS" "ROWS" "OUTLINE" "Y" + "X" "ENCODING-ID" "FORMAT" "REALLOC" "INTERNAL" "SIZES-LIST" "MAX-ADVANCE-WIDTH" "DONE-FACE" "SIZE" "SUB-GLYPH" + "BBOX" "POINTER" "DELTA" "CEIL-FIX" "PARAMETER" "OFFSET" "MATRIX" "FACE-REC" "GRAY-SPANS" "PALETTE-MODE" + "NUM-FIXED-SIZES" "BYTE" "SPAN" "VECTOR-TRANSFORM" "NUM-GRAYS" "RASTER-BIT-SET-FUNC" "RENDERER" "VALUE" "BIT-TEST" + "SOURCE" "STYLE-NAME" "LINE-TO" "STREAM-DESC" "LONG" "UNIT-VECTOR" "LIST-NODE-REC" "HORI-BEARING-X" "VERT-ADVANCE" + "CUBIC-TO" "GENERIC-FINALIZER" "CHAR" "PTR-DIST" "UFAST" "DESCRIPTOR" "SET-CHAR-SIZE" "LINEAR-HORI-ADVANCE" + "MAX-ADVANCE" "AUTOHINT" "FIXED" "OPEN-FLAGS" "BASE" "ERROR" "NUM-GLYPHS" "DATA" "RENDER-MODE" "CHARMAPS" "FACE" + "F26DOT6" "OTHER" "RASTER-PARAMS" "SET-CHARMAP" "NUM-CHARMAPS" "LOAD-GLYPH" "RASTER-BIT-TEST-FUNC" "RASTER-NEW" + "FAMILY-NAME" "DONE-FREE-TYPE" "BIT-SET" "VERT-BEARING-X" "F2DOT14" "CLOSE" "STREAM-IO" "FACE-FLAGS" "BOOL" + "SHORT" "PALETTE" "C" "PALETTE-MODE-" "SIZE-REC-" "B" "A" "RENDER_MODE" "RIGHT_GLYPH" "SIZE-INTERNAL-REC-" + "CHAR-MAP-REC-" "RASTER-FUNCS-" "SUB-GLYPH-" "SLOT-INTERNAL-REC-" "OUTLINE-" "RENDER-MODE-" "GLYPH-METRICS-" + "PARAMETER-" "LOAD_FLAGS" "MATRIX-" "ARGS" "GLYPH_INDEX" "OUTLINE-FLAGS-" "MEMORY-REC-" "PIXEL_WIDTH" "VEC" + "HORZ_RESOLUTION" "LIST-REC-" "STREAM-REC-" "BUFFER_MAX" "LIBRARY-REC-" "SPAN-" "GLYPH-SLOT-REC-" + "VERT_RESOLUTION" "LEFT_GLYPH" "PIXEL-MODE-" "AFACE" "MODULE-REC-" "PIXEL_HEIGHT" "CHARCODE" "AKERNING" "ALIBRARY" + "LIST-NODE-REC-" "KERNING-MODE-" "FACE-REC-" "BITMAP-SIZE-" "DRIVER-REC-" "FILE_SIZE" "STREAM-DESC-" + "FACE-INTERNAL-REC-" "FILEPATHNAME" "UNIT-VECTOR-" "PARAMETERS" "RASTER-PARAMS-" "OUTLINE-FUNCS-" "CHAR_HEIGHT" + "BITMAP-" "FILE_BASE" "KERN_MODE" "CHAR_CODE" "RENDERER-REC-" "RASTER-REC-" "VECTOR-" "SIZE-METRICS-" "CHAR_WIDTH" + "GENERIC-" "ENCODING-" "FACE_INDEX" "SLOT" "GLYPH-FORMAT-" "OPEN-ARGS-" "BBOX-" "SIZE_S")) + + + +(defpackage :mcclim-freetype + (:use :climi :clim :clim-lisp) + (:export :*freetype-font-path*) + (:import-from :cffi + #:with-foreign-slots + #:foreign-slot-value + #:foreign-alloc) + (:import-from :freetype + #:glyph + #:bitmap + #:width + #:pitch + #:rows + #:buffer + #:x #:y + #:bitmap-left + #:bitmap-top + #:advance + #:ascender + #:descender + #:size_s + #:metrics) + +;;; (:import-from #+cmucl :alien +;;; #+sbcl :sb-alien +;;; :slot :make-alien :alien :deref) + ) diff --git a/Experimental/freetype/mcclim-freetype-cffi.asd b/Experimental/freetype/mcclim-freetype-cffi.asd new file mode 100644 index 00000000..eb749229 --- /dev/null +++ b/Experimental/freetype/mcclim-freetype-cffi.asd @@ -0,0 +1,86 @@ +;;;; -*- Lisp -*- + +;;;--------------------------------------------------------------------------- +;;; This is currently a *NON-FUNCTIONING* system definition for +;;; FREETYPE with CFFI instead of CMUCL/SBCL style alien definitions. +;;; This is a work in progress and should not be used by anyone until +;;; its availability is announced. [2006/05/23:rpg] +;;;--------------------------------------------------------------------------- + + +#| +To autoload mcclim-freetype after mcclim, link this file to a +directory in your asdf:*central-registry* and add the following to +your lisp's init file: + + (defmethod asdf:perform :after ((o asdf:load-op) (s (eql (asdf:find-system :clim-clx)))) + (asdf:oos 'asdf:load-op :mcclim-freetype)) +|# + +(defpackage :mcclim-freetype-system (:use :cl :asdf)) +(in-package :mcclim-freetype-system) + +(defclass uncompiled-cl-source-file (source-file) ()) + +(defmethod perform ((o compile-op) (f uncompiled-cl-source-file)) + t) +(defmethod perform ((o load-op) (f uncompiled-cl-source-file)) + (mapcar #'load (input-files o f))) +(defmethod output-files ((operation compile-op) (c uncompiled-cl-source-file)) + nil) +(defmethod input-files ((operation load-op) (c uncompiled-cl-source-file)) + (list (component-pathname c))) +(defmethod operation-done-p ((operation compile-op) (c uncompiled-cl-source-file)) + t) +(defmethod source-file-type ((c uncompiled-cl-source-file) (s module)) + "lisp") + +(defsystem :mcclim-freetype + :depends-on (:clim-clx :cffi) + :serial t + :components + ((:file "freetype-package-cffi") + (:uncompiled-cl-source-file "freetype-cffi") + (:file "freetype-fonts-cffi"))) + + +;;; Freetype autodetection + +(defun parse-fontconfig-output (s) + (let* ((match-string (concatenate 'string (string #\Tab) "file:")) + (matching-line + (loop for l = (read-line s nil nil) + while l + if (= (mismatch l match-string) (length match-string)) + do (return l))) + (filename (when matching-line + (probe-file + (subseq matching-line + (1+ (position #\" matching-line :from-end nil :test #'char=)) + (position #\" matching-line :from-end t :test #'char=)))))) + (when filename + (make-pathname :directory (pathname-directory filename))))) + +(defun warn-about-unset-font-path () + (warn "~%~%NOTE:~%~ +* Remember to set mcclim-freetype:*freetype-font-path* to the + location of the Bitstream Vera family of fonts on disk. If you + don't have them, get them from http://www.gnome.org/fonts/~%~%~%")) + +#+sbcl +(defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) + (let ((fc-match (sb-ext:find-executable-in-search-path "fc-match"))) + (if (null fc-match) + (warn-about-unset-font-path) + (let* ((process (sb-ext:run-program fc-match `("-v" "Bitstream Vera") + :output :stream + :input nil)) + (font-path (parse-fontconfig-output (sb-ext:process-output process)))) + (if (null font-path) + (warn-about-unset-font-path) + (setf (symbol-value (intern "*FREETYPE-FONT-PATH*" :mcclim-freetype)) + font-path)))))) + +#-sbcl +(defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) + (warn-about-unset-font-path)) -- cgit v1.2.3-70-g09d2