pax_global_header00006660000000000000000000000064140011203360014500gustar00rootroot0000000000000052 comment=d1cb862af9fe27559ef18a3f0e91511e837a72f3 zpb-ttf-release-1.0.4/000077500000000000000000000000001400112033600145065ustar00rootroot00000000000000zpb-ttf-release-1.0.4/LICENSE000066400000000000000000000025121400112033600155130ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. zpb-ttf-release-1.0.4/bounding-box.lisp000066400000000000000000000041021400112033600177670ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; ;;;; Bounding boxes, which are common to both the overall font and ;;;; individual glyphs. ;;;; ;;;; $Id: bounding-box.lisp,v 1.2 2006/02/18 23:13:43 xach Exp $ (in-package :zpb-ttf) (defgeneric bounding-box (object)) (macrolet ((bbox-accessor (name index) `(progn (defgeneric ,name (object) (:method (object) (aref (bounding-box object) ,index))) (defgeneric (setf ,name) (new-value object) (:method (new-value object) (setf (aref (bounding-box object) ,index) new-value)))))) (bbox-accessor xmin 0) (bbox-accessor ymin 1) (bbox-accessor xmax 2) (bbox-accessor ymax 3)) (defmethod bounding-box ((object array)) object) zpb-ttf-release-1.0.4/cmap.lisp000066400000000000000000000215141400112033600163220ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; Loading data from the "cmap" table. ;;; ;;; https://docs.microsoft.com/en-us/typography/opentype/spec/cmap ;;; http://developer.apple.com/fonts/TTRefMan/RM06/Chap6cmap.html ;;; ;;; $Id: cmap.lisp,v 1.15 2006/03/23 22:23:32 xach Exp $ (in-package #:zpb-ttf) (deftype cmap-value-table () `(array (unsigned-byte 16) (*))) ;;; FIXME: "unicode-cmap" is actually a format 4 character map that ;;; happens to currently be loaded from a Unicode-compatible ;;; subtable. However, other character maps (like Microsoft's Symbol ;;; encoding) also use format 4 and could be loaded with these ;;; "unicode" objects and functions. (defclass unicode-cmap () ((segment-count :initarg :segment-count :reader segment-count) (end-codes :initarg :end-codes :reader end-codes) (start-codes :initarg :start-codes :reader start-codes) (id-deltas :initarg :id-deltas :reader id-deltas) (id-range-offsets :initarg :id-range-offsets :reader id-range-offsets) (glyph-indexes :initarg :glyph-indexes :accessor glyph-indexes))) (defun load-unicode-cmap (stream) "Load a Unicode character map of type 4 from STREAM starting at the current offset." (let ((format (read-uint16 stream))) (when (/= format 4) (error 'unsupported-format :location "\"cmap\" subtable" :actual-value format :expected-values (list 4)))) (let ((table-start (- (file-position stream) 2)) (subtable-length (read-uint16 stream)) (language-code (read-uint16 stream)) (segment-count (/ (read-uint16 stream) 2)) (search-range (read-uint16 stream)) (entry-selector (read-uint16 stream)) (range-shift (read-uint16 stream))) (declare (ignore language-code search-range entry-selector range-shift)) (flet ((make-and-load-array (&optional (size segment-count)) (loop with array = (make-array size :element-type '(unsigned-byte 16) :initial-element 0) for i below size do (setf (aref array i) (read-uint16 stream)) finally (return array))) (make-signed (i) (if (logbitp 15 i) (1- (- (logandc2 #xFFFF i))) i))) (let ((end-codes (make-and-load-array)) (pad (read-uint16 stream)) (start-codes (make-and-load-array)) (id-deltas (make-and-load-array)) (id-range-offsets (make-and-load-array)) (glyph-index-array-size (/ (- subtable-length (- (file-position stream) table-start)) 2))) (declare (ignore pad)) (make-instance 'unicode-cmap :segment-count segment-count :end-codes end-codes :start-codes start-codes ;; these are really signed, so sign them :id-deltas (map 'vector #'make-signed id-deltas) :id-range-offsets id-range-offsets :glyph-indexes (make-and-load-array glyph-index-array-size)))))) (defmethod invert-character-map (font-loader) "Return a vector mapping font indexes to code points." (with-slots (start-codes end-codes) (character-map font-loader) (declare (type cmap-value-table start-codes end-codes)) (let ((points (make-array (glyph-count font-loader) :initial-element -1))) (dotimes (i (1- (length end-codes)) points) (loop for j from (aref start-codes i) to (aref end-codes i) for font-index = (code-point-font-index j font-loader) when (minusp (svref points font-index)) do (setf (svref points font-index) j)))))) (defgeneric code-point-font-index (code-point font-loader) (:documentation "Return the index of the Unicode CODE-POINT in FONT-LOADER, if present, otherwise NIL.") (:method (code-point font-loader) (let ((cmap (character-map font-loader))) (with-slots (end-codes start-codes id-deltas id-range-offsets glyph-indexes) cmap (declare (type cmap-value-table end-codes start-codes id-range-offsets glyph-indexes)) (dotimes (i (segment-count cmap) 1) (when (<= code-point (aref end-codes i)) (return (let ((start-code (aref start-codes i)) (id-range-offset (aref id-range-offsets i)) (id-delta (aref id-deltas i))) (cond ((< code-point start-code) 0) ((zerop id-range-offset) (logand #xFFFF (+ code-point id-delta))) (t (let* ((glyph-index-offset (- (+ i (ash id-range-offset -1) (- code-point start-code)) (segment-count cmap))) (glyph-index (aref (glyph-indexes cmap) glyph-index-offset))) (logand #xFFFF (+ glyph-index id-delta))))))))))))) (defgeneric font-index-code-point (glyph-index font-loader) (:documentation "Return the code-point for a given glyph index.") (:method (glyph-index font-loader) (let ((point (aref (inverse-character-map font-loader) glyph-index))) (if (plusp point) point 0)))) (defmethod load-cmap-info ((font-loader font-loader)) (seek-to-table "cmap" font-loader) (with-slots (input-stream) font-loader (let ((start-pos (file-position input-stream)) (version-number (read-uint16 input-stream)) (subtable-count (read-uint16 input-stream)) (foundp nil)) (declare (ignore version-number)) (loop repeat subtable-count for platform-id = (read-uint16 input-stream) for platform-specific-id = (read-uint16 input-stream) for offset = (+ start-pos (read-uint32 input-stream)) when (and (= platform-id +microsoft-platform-id+) (= platform-specific-id +microsoft-unicode-bmp-encoding-id+)) do (file-position input-stream offset) (setf (character-map font-loader) (load-unicode-cmap input-stream)) (setf (inverse-character-map font-loader) (invert-character-map font-loader) foundp t) (return)) (unless foundp (error "Could not find supported character map in font file"))))) (defun available-character-maps (loader) (seek-to-table "cmap" loader) (let ((stream (input-stream loader))) (let ((start-pos (file-position stream)) (version-number (read-uint16 stream)) (subtable-count (read-uint16 stream))) (declare (ignore start-pos)) (assert (zerop version-number)) (dotimes (i subtable-count) (let ((platform-id (read-uint16 stream)) (encoding-id (read-uint16 stream)) (offset (read-uint32 stream))) (declare (ignore offset)) (format t "~D (~A) - ~D (~A)~%" platform-id (platform-id-name platform-id) encoding-id (encoding-id-name platform-id encoding-id))))))) zpb-ttf-release-1.0.4/conditions.lisp000066400000000000000000000062341400112033600175550ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; Conditions ;;; ;;; $Id: conditions.lisp,v 1.3 2006/02/18 23:13:43 xach Exp $ (in-package #:zpb-ttf) (define-condition regrettable-value () ((actual-value :initarg :actual-value :accessor actual-value) (expected-values :initarg :expected-values :accessor expected-values) (description :initarg :description :initform nil :accessor description) (location :initarg :location :initform nil :accessor location)) (:report (lambda (c s) (format s "~:[Regrettable~;~:*~A~] value~:[~;~:* in ~A~]: ~ ~A (expected ~{~A~^ or ~})" (description c) (location c) (actual-value c) (expected-values c))))) (define-condition regrettable-hex-value (regrettable-value) ((size :initarg :size :initform 8 :accessor size) (actual-value :reader %actual-value) (expected-values :reader %expected-values))) (defmethod actual-value ((c regrettable-hex-value)) (format nil "#x~v,'0X" (size c) (%actual-value c))) (defmethod expected-values ((c regrettable-hex-value)) (mapcar (lambda (v) (format nil "#x~v,'0X" (size c) v)) (%expected-values c))) (define-condition bad-magic (regrettable-hex-value) ((description :initform "Bad magic"))) (define-condition unsupported-version (regrettable-hex-value) ((description :initform "Unsupported version"))) (define-condition unsupported-format (regrettable-hex-value) ((description :initform "Unsupported format"))) (define-condition unsupported-value (regrettable-value) ((description :initform "Unsupported"))) (defun check-version (location actual &rest expected) (or (member actual expected :test #'=) (error 'unsupported-version :location location :actual-value actual :expected-values expected))) zpb-ttf-release-1.0.4/doc/000077500000000000000000000000001400112033600152535ustar00rootroot00000000000000zpb-ttf-release-1.0.4/doc/index.html000066400000000000000000000533261400112033600172610ustar00rootroot00000000000000 ZPB-TTF - TrueType font file access for Common Lisp

ZPB-TTF - TrueType font file access for Common Lisp

Abstract

TrueType fonts have a publicly documented file format. ZPB-TTF is a TrueType file parser that provides an interface for reading typographic metrics, glyph outlines, and other information from the file. It is available under a BSD-like license. The latest version is 1.0.3, released on July 18th, 2013.

TrueType is a registered trademark of Apple Computer, Inc.

Download shortcut: http://www.xach.com/lisp/zpb-ttf.tgz

Contents

  1. Limitations
  2. Overview
  3. Glyph Example
  4. The ZPB-TTF Dictionary
    1. open-font-loader
    2. close-font-loader
    3. with-font-loader
    4. glyph-count
    5. collection-font-count
    6. collection-font-index
    7. name-entry-value
    8. find-name-entry
    9. value
    10. italic-angle
    11. underline-thickness
    12. underline-position
    13. fixed-pitch-p
    14. units/em
    15. ascender
    16. descender
    17. line-gap
    18. postscript-name
    19. full-name
    20. family-name
    21. subfamily-name
    22. all-kerning-pairs
    23. glyph-exists-p
    24. index-glyph
    25. find-glyph
    26. bounding-box
    27. xmin
    28. ymin
    29. xmax
    30. ymax
    31. x
    32. y
    33. on-curve-p
    34. contour-count
    35. contour
    36. contours
    37. do-contours
    38. explicit-contour-points
    39. do-contour-segments
    40. do-contour-segments*
    41. code-point
    42. font-index
    43. advance-width
    44. left-side-bearing
    45. right-side-bearing
    46. kerning-offset
    47. string-bounding-box
  5. Feedback

Limitations

ZPB-TTF has the following limitations:

Overview

Font files are loaded by creating font loaders. A font loader has information that applies to the font as a whole, such as its overall bounding box and other typographic metrics, the number of glyphs it contains, and a character map that can be used to convert a character set index into a glyph index meaningful to the font loader.

A font loader can also be used to create and find glyphs. A glyph object has information about an individual glyph such as typographic metrics and its outline.

Glyph outlines are made up of arrays of control points. An array of control points is called a contour. Contours define the shape of the glyph. For example, in most fonts, the glyph for the character #\I has one contour defining its outline. The glyph for the character #\O has two contours: one for the outer edge, and one for the inner edge.

This documentation is not meant to be a substitute for the TrueType file format documentation. For file format details, see the specifications from either Apple or Microsoft.

Glyph Example

This image is a rendering of the Greek small letter lambda (U+03BB) from the Times New Roman TrueType font. The visualization was programmed by Frederic Jolliton and rendered with CL-VECTORS.

The dark gray grid lines represent the axes of the glyph coordinate system. Light grid lines are drawn at intervals of 256 em-square units.

Black squares represent the control points returned from CONTOUR. Solid black squares are points on the outline (ON-CURVE-P returns true), and hollow black squares are not on the outline. Solid red squares represent implicit control points on the glyph outline; they are not in the original contour, but they would be returned in a new contour created with EXPLICIT-CONTOUR-POINTS.

The alternating blue and green portions of the glyph outline represent the separate segments whose start, control, and end points were bound with DO-CONTOUR-SEGMENTS.

The ZPB-TTF Dictionary

[Function]
open-font-loader font-file-designator &key (collection-index 0) => font-loader

Creates and returns a font-loader object from font-file-designator, which should be either a pathname, pathname namestring, a stream, or a font-loader object. If font-file-designator is a TrueType Collection, collection-index specifies the index of the font to load from the collection.

[Function]
close-font-loader font-loader =>

Closes any open resources held by font-loader.

[Macro]
with-font-loader (font-loader font-loader-designator &key (collection-index 0)) &body body =>

Performs body with font-loader bound to a font-loader object created as if with (open-font-loader font-loader-designator). Automatically closes the font-loader when finished.

[Function]
glyph-count font-loader => number

Returns the number of glyphs available in font-loader.

[Function]
collection-font-count font-loader => number

If font-loader was loaded from a TrueType Collection, returns the number of fonts available in the collection, otherwise returns NIL.

[Function]
collection-font-index font-loader => number

If font-loader was loaded from a TrueType Collection, returns the index of the loaded font in the collection, otherwise returns NIL.

[Function]
name-entry-value name-designator font-loader => string

Returns an entry from the TrueType "name" table, which contains human-readable values for copyright info, trademark notices, creator names, and the like.

name-designator may be either an integer ID from the table of NameIDs in the TrueType "name" table specification, or a keyword designating such an ID. Valid keywords and their IDs are:

Keyword  ID
:COPYRIGHT-NOTICE0
:FONT-FAMILY1
:FONT-SUBFAMILY2
:UNIQUE-SUBFAMILY3
:FULL-NAME4
:NAME-TABLE-VERSION5
:POSTSCRIPT-NAME6
:TRADEMARK-NOTICE7
:MANUFACTURER-NAME8
:DESIGNER9
:DESCRIPTION10
:VENDOR-URL11
:DESIGNER-URL12
:LICENSE-DESCRIPTION13
:LICENCE-INFO-URL14
:RESERVED15
:PREFERRED-FAMILY16
:PREFERRED-SUBFAMILY17
:COMPATIBLE-FULL18
:SAMPLE-TEXT19

If the font does not provide any "name" table entry for the given name-designator, returns NIL.

[Function]
find-name-entry platform-id language-id name-id font-loader => name-entry

This is the low-level interface used by NAME-ENTRY-VALUE. platform-id, language-id, and name-id should be integer ID values from the TrueType "name" table specification. If the combination of IDs is found in the name table, a name-entry object is returned, otherwise NIL is returned.

[Function]
value name-entry => string

Returns the string value of a name-entry object.

[Function]
italic-angle font-loader => number

Returns the typographic italic angle of font-loader.

[Function]
underline-thickness font-loader => number

Returns the typographic underline thickness of font-loader.

[Function]
underline-position font-loader => number

Returns the typographic underline position of font-loader.

[Function]
fixed-pitch-p font-loader => boolean

Returns true if font-loader is fixed pitch (all glyphs have the same width).

[Function]
units/em font-loader => number

Return the number of units in the typographic em-square of font-loader.

[Function]
ascender font-loader => number

Returns the typographic ascender value of font-loader.

[Function]
descender font-loader => number

Returns the typographic descender value of font-loader.

[Function]
line-gap font-loader => number

Returns the typographic line gap of font-loader.

[Generic function]
postscript-name object => string

Returns the Postscript name of object, which may be a glyph or a font-loader.

[Function]
full-name font-loader => string

Returns the full name of font-loader.

[Function]
family-name font-loader => string

Returns the family name of font-loader.

[Function]
subfamily-name font-loader => string

Returns the subfamily name of font-loader.

[Function]
all-kerning-pairs font-loader => list

Returns a list of all the kerning pairs available in font-loader. Each element of the list is itself a list, with three elements: a left glyph, a right glyph, and a numeric kerning offset.

[Function]
glyph-exists-p character-designator font-loader => boolean

Returns true if font-loader has glyph data for character-designator.

[Function]
index-glyph index font-loader => glyph

Returns the glyph at index in font-loader.

[Function]
find-glyph character-designator font-loader => glyph

Returns the glyph for character-designator in font-loader. If character-designator is an integer, it is treated as a Unicode code-point and the corresponding glyph is fetched from the font. If character-designator is a character, its char-code is used as a Unicode code-point for lookup.
Note: If the char-codes of characters the Lisp implementation do not correspond to Unicode (or a subset), this may not return the expected glyph.

If font-loader does not contain any glyphs for character-designator, the "missing glyph" glyph is returned. To test for the existence of a glyph without returning the "missing glyph" glyph, use GLYPH-EXISTS-P.

[Generic function]
bounding-box object => #(xmin ymin xmax ymax)

Returns the bounding box of object, which may be a glyph or a font-loader.

[Generic functions]
xmin object => value
ymin object => value
xmax object => value
ymax object => value

Returns the horizontal and vertical extreme values for object, which may be a glyph or font-loader. If object is a four-element vector, each function is an accessor to the appropriate entry in the vector.

[Function]
x control-point => number
y control-point => number

Returns the respective coordinate of control-point.

[Function]
on-curve-p control-point => boolean

Returns true if control-point is on the contour outline.

[Function]
contour-count glyph => number

Returns the number of contours of glyph. Some glyphs, such as the glyph for the Space character, may have zero contours.

[Function]
contour glyph index => vector

Returns the indexth contour from the contours of glyph. A contour is represented as a vector of control point objects. Each control point may be on (touching) or off (not touching) the the contour outline.

TrueType files may store contours that have implicit control points. When two consecutive control points are off the contour outline, there is an implied control point at the midpoint between them on the contour curve.

[Function]
contours glyph => vector

Returns all contours of glyph as a vector.

[Macro]
do-contours (contour glyph &optional result) &body body => result

Performs body for each contour in glyph, with the contour bound to contour. Returns result (evaluated) at the end of processing.

[Function]
explicit-contour-points contour => vector

Returns a vector of points that is the same as contour with the implicit contour points inserted.

[Macro]
do-contour-segments (start control end) contour &body body =>

For convenience, a TrueType contour may be thought of as being made up of connected segments. Each segment is either a straight line from one point on the outline to another, or a curved line that starts with a point on the outline, is controlled by a point off the outline, and ends with a point on the outline.

DO-CONTOUR-SEGMENTS performs body for each segment of contour, with the start, control, and end variables (not evaluated) bound to the start, control, and end points of the segment. If the segment is a straight line, control is bound to NIL.

Contours of a glyph in a TrueType file may contain implied control points; two consecutive points off the outline may be treated as if there is there is an point on the outline at the midpoint between them. DO-CONTOUR-SEGMENTS synthesizes and binds any implicit points as needed when going through the contour segments. (See the Glyph Example for a visual explanation.)

Segments are not a TrueType glyph concept. The term is used for convenience by ZPB-TTF.

[Macro]
do-contour-segments* (control end) contour &body body =>

DO-CONTOUR-SEGMENTS* is like DO-CONTOUR-SEGMENTS, except it does not bind a start variable.

[Function]
code-point glyph => number

Returns the Unicode code point of a character glyph represents. Note: Since font glyphs may represent more than one character, this value may not be exactly what you expect. Note: Since glyphs in a font do not necessarily correspond to a code point, or to a single code point, this may not always return a meaningful value.

[Function]
font-index glyph => number

Returns the integer index of glyph in its font loader.

[Function]
advance-width glyph => number

Returns the typographic advance width of glyph.

[Function]
left-side-bearing glyph => number

Returns the typographic left side bearing of glyph.

[Function]
right-side-bearing glyph => number

Returns the typographic right side bearing of glyph.

[Function]
kerning-offset left-glyph right-glyph font-loader => number

Returns the typographic kerning adjustment needed for the advance width when left-glyph and right-glyph appear next to each other.

[Function]
string-bounding-box string font-loader &key (kerning t) => #(xmin ymin xmax ymax)

Returns the bounding box for string in the natural unit size of font-loader. If kerning is true, the inter-glyph spacing will take kerning offsets into account when calculating the bounding box.

Feedback

Please send bug reports, patches, questions, and any other feedback to Zachary Beane. zpb-ttf-release-1.0.4/doc/lambda.png000066400000000000000000000432731400112033600172120ustar00rootroot00000000000000PNG  IHDR;V_ IDATx|T{һJ ( %X"*TP((EHW@ZM"]RE-@T !e?9Y&{9ʋWyyr=3g6l؟額 YH7o޴: >>tVl'd cX@2d,kX{@ƒ%cmkX2VdM cK 2 d= cX[Aƒ6d,k+X2&%cmK2d cX@2d,kX{@ƒ%cmkX2VdM cK 2 d= cX[Aƒ6d,k+X2&Ռ]~̄Z`X{Ʋo+0zhcqcƌɑnݺyj]Ϟ=(z7 2aaa,YXc.\0H2VX0M~+T-.٭fMiO>y8|))jB۸=Q1???ćS1u mthc8+1v,:vDȓopU2Vic^& a@zGpdlÔ zV5kн;C8cUUXϜù][2,CWѾ=[o!"B/ 2S8*1.ym<5'L@@^}`*d=p+AQX[6IB&MBh>Xklbl R&b";~OnOr$1#GP!$`R c=uQ!i 1ŋhO>ݻ kS0~õ{T@?66 Щc,O2 /_ l2qd@욶hQl*<X{(1 Dd;4iO3g꽉-2a+"+RT@2ΞEh`G NX{gnf.S c%C*dS׽+6 ")K d=cwbga+1o_:sOϥ &!c{NjVHjHDb34 FҒ+%QrIo2^脌9uaXVB)kT7#:v@]o,ҦaZd=PI QMX,@B c큺ñ(|ewdɘ\=vj6LBcmѶk53|veshDC)#2h`;1ەZc밮 8| DG {X{!W.G\qZԩ2{tA2ȑ8rHXX.X{3g"}"Q;S6b%K.w.. 2eQ5h"22G2b,fybX'[1pcےTcǍn󐄤^c6XٳڸaDpC9cےTc4O?Lfh-o(Y4qjD߾2DT1V {"1ݻf_IR3: @>7q&m?c|Wt5!kdqPRRҪU?a?(u7?./D Cn2S/Wq5?O>2&tg>]\B2qAH;=.[s _~YշɾʹP4&cyVx| 1:a;e9-Ϣea„o/d=0XTߗ9yR%Kd V$+beء=tI` <0Af+M N2ժ~G`AAȼx &L2VÇ69rD{^a,#8X3it0 >"cI6k}b"*UYd/_ @\뇌&[ ekB={ (ށ>/=k09,CSa Ac̜|hO3]oC͵ՕLC ڹ֭#_KJ۞f۫vS'?ϢGGugzMgC:!cƾms}1)))0Ƹԭ7dxU)EnjAϞz cf._<}@HHҦ><`/&\hoxin@11h8WNpBbӦX7#`,}8pP˖;ҍ7mZV"2N#fm,;+7NWK2H7;}M9Bi职ҍ4(),~msc|066];Ol9!>^3ҍ}uman,_X!3}jByJ>0>O?1XFM\U~ wތrMMſ;w4cp|6&뫠J*=:uJ325%(ƍx9Ýb :.tZО!c\c0y>nv5+0 {Ǐ҆r]mzoV5wo'04 ziCNɓ 1X h6ݹ=Xr49sб`/‘c׭Ԁrg{i{ڡB,19>ޢ@-Zx/SؘXe\)e&߯ c\cpڲɆ{U2ě!fTmIW6 c\cg¬|Bca_95hm[,Zd=h,?2i_caH. 1od=hk|WɓƎ¨!f%s<0#cDcϜV$/kCZc/RaNJֆg k${v3?獅2O]]ݹ?Ab""XntLeȧM;5t̅Xaj2k$Nw6 Th,H,76yMJ/\p] k$r9L&M2Zb,W25h68X;؉ .fh'5e@Ӧy3a5'χ|q}׮]-Z蔻;n` >`֬Y?"cxcCxW_վْ8LTTkv}~# Bco᭩DM?B2| Dd⑧NcmdTJd=o,k#30E]lHPX,4ɳ"vd= cU16EPd撙/p}fπi) -Kfˇi1cnEz/ c  &26[`OS2`_B6eY2YB2Gp? /`L@7nh3?ݿK2!F)cb`?3t( k̨8J{'J$_~A:^!cjƿqbk;2; Ä7h drg >kXMAJ~俆kqvO?/kXeW'߱]/kXom8/rB2VEc|13j=kXeEc8dϞ㑱U5 ]޾}O2VQcWaUSx\N `z2<ȓD8ÆϵoX{@*j,.nV ۶n]2;C>A3'X@ƪkn쮁qV cHv.g B2V]cXdFԯOڄW3efÇ=Ұ:WomG\]~S^p,DD*m쮿vK-i,fԙ3tVeP8s}\b@ƪnlwtA֬ /$6UؕX_ ΝM=d­Q]X2V-b@ 4aFc*Qqi)Kƪlx /خ]1m%cb_323dfzT;odi)d,92bs(YRNBƒ !XF"w YZ K*Xc۴KRX2V!;~ÈIKƪ(QIFek5hڔ71 cXU_<[c7%%c 2 !.xlEڔaU%cgO 42c!}pEV 2vZ] ٳѩWd cX<ĝ'OlY@ƒs q^c(@ƒ3q"ڵǝ-j.T%c$9J!<\@(Ǝ}td,k% %#Kdcw3ψrX22_U`QM {WLGBƒnj̓ڵmR%%c-E>}0f,%ca^1iJ]Z BX2ڴ"z6 ٝUd:E l,ti9#GK cX _~)8Wc| |X2l]n֫'GKƚͧjwnS525,(e~&%!W.ܾ-k3!cXS=o-%Wc知nd,kR11|M%ccLl)+cm"KƚDj*kz~\\X2$~>+1c iȆ%cMV-]+1Nc;vwILC6d,k۶/N_X2 4ܹrigBƒqԑ46%s#id,+`L 26Ć ӑKYP'6VzG4H[O!cXщ~c׭CFӑKJ$:Z@A7 %*X2V"C7%UqtdAƒp9wΤ|2KTd,&MoםNcl7omI@ƒRXPG': ͑I%c NX{@Zc::!ck׋,28ɓ'3c롍 ؗ=֮}wR]pVg!Wq=ӦMcƲm<iͷ˖u$'[G'8'".\`ڛ36**,DX_:+A66ʹҧM*A$Vgdpu-nS1UR> cX( )Id0$щcOT$X2Vwo:(WqURJ2 cX1+2j$X2V Gsgٝx˜_~'#Idщ1cVd# 2Ԃ::1flr"gd$2EvA3Q ~oKr܂::1l`"& Gd,KZZG1lB,lvKraBA6ΕDIH%c0N (W`}?=dq)c[ $X28 1Gd,kM*cw`G$X2 / 8<#>'r&"QlJ2 cX#8 DE{# 25util/KutiR,mKutiE\ @|$Aƒҥqx4e JGd,aCQpn9rP쬘MO8d,O=͛E@xxAAAB^%6=ᐱd_ՅD@c`OMpX2^x˖ $ &"1'r#^lb!cXۇeI$eA!0=ᐱd^^}S+y!>3'2ӖLttQ3s7͜zW`EkpX2V]b!鈧o_ӧTFaQɀ%c,sㆨD{37K9(63d,k xf$o}Ì xOCX( 39d(J IDAT,/T+Fc@ Θ0| 99dƌ~u{MvʮEybߪ@ƒHLDb8vLlFxxh~8I%c=1kZ0DRGt8Q}ї3sx. aɁ%c,sб#gX4ivl7E?_rKƺeʇW|wp>9or cX(RP'[DƲoj> (I@ƒ٣NA$$H?tcԪ+2p3 X26{6Ŝ92̙xӍR:̅2CƒpW zpJq2Sgdl6t6Rl܈5y=Xժ\փ8Xy"H%c]Q cl^hlK\<$#97r {Ss!cXWT+zFcWξ&l "2̈́u2{Іnöz ACƒ:ݻKM8$~lhsEx Ehc4 2}H|Y]}XF5T tțT !c؇L_A^ʮ`Op$L4Ǡ%2u,X% MigtYABƒQ իkOb=b)Ҝ D,d,{ ddv]eDOGq"*DKjlؠ\An%LVc[j_3ڪ:88L;|NC>: \l~FطO{~:(Q=x'ʡOcƠS'Kdk,9G`GDd#ju~];RƝ#03|ƙOS4]%n&cQcU.}}؟x39> "2Q4]VnA;wŋm۸ ̓lyo[˄}]J݂:)SLwg,)<ph/2Q4vmÁgz0MĘç@>rnߎ'P#4T@1cbntJ ç!c9cU.h?ƞ©(˕0ᇌ}U+QB[quk< Y22V:uÃ@~GK.s{X!TC>B=o-"^4= !|8!cc[Xǎcjr6<+vlDtĉaaa؀}i{8TelNj/&;ys'?yE6^M#>>>Œt钇66… ǏG)8sF_RűqcϯA.SS8ᨱ3i'O0],L@8gTYvV<|-e 0lAժA<3` A۟{#bŋWJLٿ<Ӭ ؓ8?1}1+?XׯVIŌ:rXsb\(<8!colJ7:Æ XF4YE;gÐ67vTPuڨk\a68;j6{ !cmn/bƎ.]Ącfl؏a duINVؤ$mZBDhzA 6 Mkgc_}U[ \abhzeTBC8Qr"] b2ֶƞ9qWؚ5N\GvEWk;r1k[c{ÇkߨiΝXQR:ٝL3qAA،u4OZFq.ޝ: @Sjc 2Vf[PGcNSF'cgaVgt1} clkY}2"ǟ~/s2>6kuE۲dl*R"ǿFhF;>7X[fh k/\؅Ai׮63ov0%mXN>]/_݀ /wz9Źv0sAˍeWM<.h:E<|{cԱXFET<}3 26 ݺyj`a"0~[Š1|oc㵥aΞZc#" II;2`Ldr;f{.m׼.]WftdDc~w6?2֏MNn{xc׮i 5NA/MEj乁<2}rƭ[<1|cc/F<-4]caR_ec=g/ABUb&ͬ261Q+uI3 |195J[X56V;o65;cƲl#4z> ~X5~},YUƲS͛Θ"Er25rKcMhv=XblX*W6Gc2*Bx4o-'`d_۶VPG'۲┙6m= 8{?/g ]glzAo3û斒2llBŻtNAutb~_}ưGp <{j՞!c،utbz Ʀ %7r߄m3Һ5/2όs|olر̻ h31Cok3/]m+3MNFɒf/A4C88rD,2֟e}Lc-[?᧗,"{ _O2ouԉ֮m[xFt^G]g>'7f-ӌݳkwM-XF 8giʥBщiƾ:il't 1ׯ#_>X0vjԩcp[sux~itL.iԪ_~2?e2ia|O?݉'8=OI4_~>#d>+V4~}hqqexX8[]Kb^mҒSdz(ƲrWy=0C3i^ 2Vuc=щlc12ol(B1&k%A*m::m /1+^|{ͅйހJGn.G!dr2qal&e5\ˏ(۶dUXut"'5YeEٓ8'%E[I&2V-c}*v#cÛ7>8<|u颭*?2ᙉt>""¥ARR۶\G,b^.*0v7eԫǙT&ؖ-[4`2gVPG'bKi,;]*Zm8zl&ూ+e =λ40cQjl˟zU+j@c,˼ qBYc:kcB;ʦ((֨]2zJ;6>g D'vcW^F``P\7#Gm8a~dl޽XPPɒ75hgϭ&M zXP1gh0vXmuI2WF"mu\=svNKRۏuҨ6y\7zO¤/^\[MB=^ $#)5QV0pMc-^nwC7c{Bґpc{Ƙ17_pرc0!e2eyX_ՍMMVZؘmԄ՟l^nUhK,q<%qc{1'eS Ҧ5ZÂSPG'N 2[vM2ι?%[{BBB.]F6kZPdGҎ_M]CDDDTTؘ*85u'E:Rڷo_g?>Q8קq='NdƲ?m2k֙9,_xx"KClW_1umڵ 0gΜ6L>"OJ2~Myk=y7)Sp족ǖټ%K|_ o^zf"iȀ,sA:+n eQ6U؈+Do6Ϊ>!oq(yh_*f[kU؎&cl4{3a,txQdw0~dXD;xX)\Qcщac]+<#)H2];,\(2 <*#cEp68qERPG'3#<YH2v{4>ŏe{<xvƊ*c޹]=!$cOD҂cFFjF#c+U y:،ha.`ةS%0I2Ję3cl/vݗY$"ˠLW3YPGƲ恁ؽ[RFRgl.|mv{Kؙ3ѡfp d|E9c߾m[3;4blh(jՒ,hJ|؏>2r_mKzo 0][PG'm@ۭ򌍎F޼Z; u c'5 3b WcAJ] y"m~?m0v:<mL2VlAj;`hyB/ćeGov5{]d)#C[eVjNWب("mdM3F[T?{v7zg|E!ct 2| 5YH59@:Q3cN>G̉*߯=Pwj /yjRe4o~ymŝ;[]ۇ%rEjd&Nw\Xlc'NgwَgӾ\RqcwB>Ljp(+J+N[ ~Yv:mf#\#GqxƲkr͋7鮉J*Ʋs2!Y6Q+:cǴɉ| &7rh D:mґ  cSx*6=<.CkZcO9 ڲXutСd# MJVK&.+]5eWZXȷŷ=E7~{ㆶ#G&AzpFȾJΝξ;V+N;j}״tda?&Mdw+Ee'*< _E+]PG'egz*|c:-Olf`FY;ƶhapu Zf2bgc/FÆ~Oc,U+m J72=fP3羯0W-3vjm x6}Ԫ2ˮ^݄~4aPMԼRnެ=w#۲FhuˌeŧY_;4YJ߃mb4ӑi21 P1iԈ7bd3c77N\ӧG*c'}w}VXkՅ@fcM+wm*&`/kvneP}tL% a+8IA6Z`iutok=34Xƴ)+;*ܰõѯzo4/g״::o\grL6vicZoaEE j"9}H5lVW.ŤcQƲ2e^U6&|&kKQ&Ay\V%]wQ7S:G{v)CH Ye!X"&h^%2ni#XEZUQ$ !7rKlj,̂::jsZB7vVԨafHJJ O`C8&̇|ݝؙ쏃oVPfN:mKءS'i=ϟ?sn'_ffk~A{F~ƲSRfI_p`;p5㪡Za'̋".fܖ)#3_=y`;>c׮]=eokѣWHosһfi5utn<7̤4:zQV)k=xPMa©5.^5{w?X}7uH󐌵"maK@0ym&X 5G|ɉƮ[5(nsF$kyA .kørcGO<_~݋_`UQhm2kŨ"m45ثoᖞƲ7N=>A+vZ &?%X|9궔+m$!XgA#G|VXڤYyN(2R3MR%\I\H`~y^ *JVڕ++JDB~kV A?JA8GwܽKJzsvR/c{_6ZLϞk2HLL g"#G QQ#CjIDATccx, X x-mitXKt&>9<7>llڕㄌYkEx5 rrAǎUPڝCQZdd rp}na HcQkVlYEX y]|Ȁx`, f_BXN"NdfWkue^m\{cd<-whkƈ Jx2hbUN6+d̞ʕŜlɓgSvcG׮\yåKک{\Dd |vsjc}Y5{uV#O>Ѿ\ cUY.^}⑚Ʋ6mB 0vTVvhv.IIx tD`JMc/$f!1^c'b2طO@*i-oM*]nQ1xk׌7 ө6YdJ  }W-ƾu6%XALWt-қsKkGma%vaX(d d3~.2NkcKy'>sΠ*Իwoeȑ80go?7;},yfttt&c&88E/z_ ڪU+)Gݿύ Xwc--ٮnh,1oĆ 0`_FR? <Y޽{ىY'O'k]f0 e'3c(|y&%U~ s&222H8}{i;Fbdc4΃<%QtG+`KB.+WjG'.¾5m7.\(X_ cwf$pg<o[mF jٶyGZ16[;kd_v|ƺ>'od`=.^g? %cX[X?%cmK2d cX@2d,kX{Sǽ4B:wMuOXkv?AIENDB`zpb-ttf-release-1.0.4/font-loader-interface.lisp000066400000000000000000000153611400112033600215550ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; Interface functions for creating, initializing, and closing a ;;; FONT-LOADER object. ;;; ;;; $Id: font-loader-interface.lisp,v 1.6 2006/03/23 22:20:35 xach Exp $ (in-package #:zpb-ttf) (defun arrange-finalization (object stream) (flet ((quietly-close (&optional object) (declare (ignore object)) (ignore-errors (close stream)))) #+sbcl (sb-ext:finalize object #'quietly-close) #+cmucl (ext:finalize object #'quietly-close) #+clisp (ext:finalize object #'quietly-close) #+allegro (excl:schedule-finalization object #'quietly-close))) ;;; ;;; FIXME: move most/all of this stuff into initialize-instance ;;; (defun open-font-loader-from-stream (input-stream &key (collection-index 0)) (let ((magic (read-uint32 input-stream)) (font-count)) (when (/= magic #x00010000 #x74727565 #x74746366) (error 'bad-magic :location "font header" :expected-values (list #x00010000 #x74727565 #x74746366) :actual-value magic)) (when (= magic #x74746366) (let ((version (read-uint32 input-stream))) (check-version "ttc header" version #x00010000 #x00020000) (setf font-count (read-uint32 input-stream)) (let* ((offset-table (make-array font-count)) (dsig)) (when (> collection-index font-count) (error 'unsupported-value :description "Font index out of range" :actual-value collection-index :expected-values (list font-count))) (loop for i below font-count do (setf (aref offset-table i) (read-uint32 input-stream))) (when (= version #x00020000) (let ((flag (read-uint32 input-stream)) (length (read-uint32 input-stream)) (offset (read-uint32 input-stream))) (list flag length offset) (when (= #x44534947 flag) (setf dsig (list length offset))))) ;; seek to font offset table (file-position input-stream (aref offset-table collection-index)) (let ((magic2 (read-uint32 input-stream))) (when (/= magic2 #x00010000 #x74727565) (error 'bad-magic :location "font header" :expected-values (list #x00010000 #x74727565) :actual-value magic2)))))) (let* ((table-count (read-uint16 input-stream)) (font-loader (make-instance 'font-loader :input-stream input-stream :table-count table-count :collection-font-cont font-count :collection-font-index (when font-count collection-index)))) ;; skip the unused stuff: ;; searchRange, entrySelector, rangeShift (read-uint16 input-stream) (read-uint16 input-stream) (read-uint16 input-stream) (loop repeat table-count for tag = (read-uint32 input-stream) for checksum = (read-uint32 input-stream) for offset = (read-uint32 input-stream) for size = (read-uint32 input-stream) do (setf (gethash tag (tables font-loader)) (make-instance 'table-info :offset offset :name (number->tag tag) :size size))) (load-maxp-info font-loader) (load-head-info font-loader) (load-kern-info font-loader) (load-loca-info font-loader) (load-name-info font-loader) (load-cmap-info font-loader) (load-post-info font-loader) (load-hhea-info font-loader) (load-hmtx-info font-loader) (setf (glyph-cache font-loader) (make-array (glyph-count font-loader) :initial-element nil)) font-loader))) (defun open-font-loader-from-file (thing &key (collection-index 0)) (let ((stream (open thing :direction :input :element-type '(unsigned-byte 8)))) (let ((font-loader (open-font-loader-from-stream stream :collection-index collection-index))) (arrange-finalization font-loader stream) font-loader))) (defun open-font-loader (thing &key (collection-index 0)) (typecase thing (font-loader (cond ((= collection-index (collection-font-index thing)) (unless (open-stream-p (input-stream thing)) (setf (input-stream thing) (open (input-stream thing)))) thing) (t (open-font-loader-from-file (input-stream thing) :collection-index collection-index)))) (stream (if (open-stream-p thing) (open-font-loader-from-stream thing :collection-index collection-index) (error "~A is not an open stream" thing))) (t (open-font-loader-from-file thing :collection-index collection-index)))) (defun close-font-loader (loader) (close (input-stream loader))) (defmacro with-font-loader ((loader file &key (collection-index 0)) &body body) `(let (,loader) (unwind-protect (progn (setf ,loader (open-font-loader ,file :collection-index ,collection-index)) ,@body) (when ,loader (close-font-loader ,loader))))) zpb-ttf-release-1.0.4/font-loader.lisp000066400000000000000000000130261400112033600176130ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; The font-loader object, which is the primary interface for ;;; getting glyph and metrics info. ;;; ;;; $Id: font-loader.lisp,v 1.26 2006/03/23 22:21:40 xach Exp $ (in-package #:zpb-ttf) (defclass font-loader () ((tables :initform (make-hash-table) :reader tables) (input-stream :initarg :input-stream :accessor input-stream :documentation "The stream from which things are loaded.") (table-count :initarg :table-count :reader table-count) ;; from the 'head' table (units/em :accessor units/em) (bounding-box :accessor bounding-box) (loca-offset-format :accessor loca-offset-format) ;; from the 'loca' table (glyph-locations :accessor glyph-locations) ;; from the 'cmap' table (character-map :accessor character-map) (inverse-character-map :accessor inverse-character-map) ;; from the 'maxp' table (glyph-count :accessor glyph-count) ;; from the 'hhea' table (ascender :accessor ascender) (descender :accessor descender) (line-gap :accessor line-gap) ;; from the 'hmtx' table (advance-widths :accessor advance-widths) (left-side-bearings :accessor left-side-bearings) ;; from the 'kern' table (kerning-table :initform (make-hash-table) :accessor kerning-table) ;; from the 'name' table (name-entries :initform nil :accessor name-entries) ;; from the 'post' table (italic-angle :accessor italic-angle :initform 0) (fixed-pitch-p :accessor fixed-pitch-p :initform nil) (underline-position :accessor underline-position :initform 0) (underline-thickness :accessor underline-thickness :initform 0) (postscript-glyph-names :accessor postscript-glyph-names) ;; misc (glyph-cache :accessor glyph-cache) ;; # of fonts in collection, if loaded from a ttc file (collection-font-count :reader collection-font-count :initform nil :initarg :collection-font-cont) ;; index of font in collection, if loaded from a ttc file (collection-font-index :reader collection-font-index :initform nil :initarg :collection-font-index))) (defclass table-info () ((name :initarg :name :reader name) (offset :initarg :offset :reader offset) (size :initarg :size :reader size))) (defmethod print-object ((object table-info) stream) (print-unreadable-object (object stream :type t) (format stream "\"~A\"" (name object)))) ;;; tag integers to strings and back (defun number->tag (number) "Convert the 32-bit NUMBER to a string of four characters based on the CODE-CHAR of each octet in the number." (let ((tag (make-string 4))) (loop for i below 4 for offset from 24 downto 0 by 8 do (setf (schar tag i) (code-char (ldb (byte 8 offset) number)))) tag)) (defun tag->number (tag) "Convert the four-character string TAG to a 32-bit number based on the CHAR-CODE of each character." (declare (simple-string tag)) (loop for char across tag for offset from 24 downto 0 by 8 summing (ash (char-code char) offset))) ;;; Getting table info out of the loader (defmethod table-info ((tag string) (font-loader font-loader)) (gethash (tag->number tag) (tables font-loader))) (defmethod table-exists-p (tag font-loader) (nth-value 1 (table-info tag font-loader))) (defmethod table-position ((tag string) (font-loader font-loader)) "Return the byte position in the font-loader's stream for the table named by TAG." (let ((table-info (table-info tag font-loader))) (if table-info (offset table-info) (error "No such table -- ~A" tag)))) (defmethod table-size ((tag string) (font-loader font-loader)) (let ((table-info (table-info tag font-loader))) (if table-info (size table-info) (error "No such table -- ~A" tag)))) (defmethod seek-to-table ((tag string) (font-loader font-loader)) "Move FONT-LOADER's input stream to the start of the table named by TAG." (let ((table-info (table-info tag font-loader))) (if table-info (seek-to-table table-info font-loader) (error "No such table -- ~A" tag)))) (defmethod seek-to-table ((table table-info) (font-loader font-loader)) "Move FONT-LOADER's input stream to the start of TABLE." (file-position (input-stream font-loader) (offset table))) zpb-ttf-release-1.0.4/glyf.lisp000066400000000000000000000322471400112033600163500ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; Loading data from the 'glyf' table. ;;; ;;; $Id: glyf.lisp,v 1.13 2006/03/23 22:22:01 xach Exp $ (in-package #:zpb-ttf) (defclass control-point () ((x :initarg :x :accessor x) (y :initarg :y :accessor y) (on-curve-p :initarg :on-curve-p :reader on-curve-p))) (defun make-control-point (x y on-curve-p) (make-instance 'control-point :x x :y y :on-curve-p on-curve-p)) (defmethod print-object ((control-point control-point) stream) (print-unreadable-object (control-point stream :type t) (format stream "~D,~D~:[~;*~]" (x control-point) (y control-point) (on-curve-p control-point)))) (defmacro do-contour-segments* ((p1 p2) contour &body body) (let ((length (gensym)) (i (gensym)) (stack (gensym)) (next (gensym)) (next-point (gensym "NEXT-POINT")) (midpoint (gensym "MIDPOINT")) (contour* (gensym)) (loop (gensym "LOOP")) (body-tag (gensym "BODY")) (mid p1) (end p2)) `(let* ((,i 1) (,contour* ,contour) (,length (length ,contour*)) ,stack ,next ,mid ,end) (unless (zerop ,length) (flet ((,next-point () (when (< ,i ,length) (prog1 (aref ,contour* ,i) (incf ,i)))) (,midpoint (p0 p1) (make-control-point (/ (+ (x p0) (x p1)) 2) (/ (+ (y p0) (y p1)) 2) t))) (tagbody ,loop (setf ,mid nil ,next (,next-point)) (unless ,next (setf ,mid ,stack ,end (aref ,contour* 0)) (go ,body-tag)) (if (on-curve-p ,next) (setf ,end ,next ,mid ,stack ,stack nil) (cond (,stack (setf ,mid ,stack ,end (,midpoint ,stack ,next) ,stack ,next)) (t (setf ,stack ,next) (go ,loop)))) ,body-tag ,@body (when ,next (go ,loop)))))))) (defmacro do-contour-segments ((p0 p1 p2) contour &body body) "A contour is made up of segments. A segment may be a straight line or a curve. For each segment, bind the P0 and P2 variables to the start and end points of the segment. If the segment is a curve, set P1 to the control point of the curve, otherwise set P1 to NIL." ;; This macro started out life as a function and was converted. (let ((start p0) (contour* (gensym "CONTOUR"))) `(let ((,contour* ,contour)) (when (plusp (length ,contour*)) (let ((,start (aref ,contour* 0))) (do-contour-segments* (,p1 ,p2) ,contour* (progn ,@body) (setf ,start ,p2))))))) (defun explicit-contour-points (contour) (let ((new-contour (make-array (length contour) :adjustable t :fill-pointer 0))) (when (plusp (length contour)) (vector-push-extend (aref contour 0) new-contour)) (do-contour-segments* (p1 p2) contour (when p1 (vector-push-extend p1 new-contour)) (vector-push-extend p2 new-contour)) new-contour)) ;;; Locating a glyph's contours and bounding box in the font loader's ;;; stream, and loading them (defparameter *empty-contours* (make-array 0 :element-type '(signed-byte 16))) (defparameter *empty-bounding-box* (make-array 4 :initial-element 0 :element-type '(signed-byte 16))) (defun empty-bounding-box () (copy-seq *empty-bounding-box*)) (defun empty-contours () (copy-seq *empty-contours*)) (defun dump-compound-flags (flags) (format t "XXX flags=~16,'0B~%" flags) (let ((meanings '((0 . ARG_1_AND_2_ARE_WORDS) (1 . ARGS_ARE_XY_VALUES) (2 . ROUND_XY_TO_GRID) (3 . WE_HAVE_A_SCALE) (4 . OBSOLETE) (5 . MORE_COMPONENTS) (6 . WE_HAVE_AN_X_AND_Y_SCALE) (7 . WE_HAVE_A_TWO_BY_TWO) (8 . WE_HAVE_INSTRUCTIONS) (9 . USE_MY_METRICS) (10 . OVERLAP_COMPOUND)))) (loop for ((bit . meaning)) on meanings do (when (logbitp bit flags) (format t "...~A~%" meaning))))) (defun transform-option-count (flags) (let ((scale-p 3) (xy-scale-p 6) (2*2-scale-p 7)) (cond ((logbitp scale-p flags) 1) ((logbitp xy-scale-p flags) 2) ((logbitp 2*2-scale-p flags) 4) (t 0)))) (defun make-transformer (a b c d e f) "Given the elements of the transformation matrix specified by A, B, C, D, E, and F, return a function of two arguments that returns the arguments transformed as multiple values. Ref: http://developer.apple.com/fonts/TTRefMan/RM06/Chap6glyf.html" (let ((m (max (abs a) (abs b))) (n (max (abs c) (abs d)))) (when (<= (abs (- (abs a) (abs b))) 33/65536) (setf m (* m 2))) (when (<= (abs (- (abs c) (abs d))) 33/65536) (setf n (* n 2))) (lambda (x y) (values (* m (+ (* (/ a m) x) (* (/ c m) y) e)) (* n (+ (* (/ b n) x) (* (/ d n) y) f)))))) (defun transform-contours (fn contours) "Call FN with the X and Y coordinates of each point of each contour in the vector CONTOURS. FN should return two values, which are used to update the X and Y values of each point." (loop for contour across contours do (loop for p across contour do (setf (values (x p) (y p)) (funcall fn (x p) (y p)))))) (defun merge-contours (contours-list) (let* ((total-contours (loop for contours in contours-list summing (length contours))) (merged (make-array total-contours)) (i 0)) (dolist (contours contours-list merged) (loop for contour across contours do (setf (aref merged i) contour) (incf i))))) (defun read-compound-contours (loader) (let ((contours-list '()) (stream (input-stream loader))) (loop (let ((flags (read-uint16 stream)) (font-index (read-uint16 stream))) (let ((position (file-position stream)) (contours (read-contours-at-index font-index loader))) (push contours contours-list) (file-position stream position) (let ((args-words-p (logbitp 0 flags)) (args-xy-values-p (logbitp 1 flags)) (more-components-p (logbitp 5 flags)) arg1 arg2) (cond ((and args-words-p args-xy-values-p) (setf arg1 (read-int16 stream) arg2 (read-int16 stream))) (args-words-p (setf arg1 (read-uint16 stream) arg2 (read-uint16 stream)) (error "Compound glyphs relative to indexes not yet supported")) (args-xy-values-p (setf arg1 (read-int8 stream) arg2 (read-int8 stream))) (t (setf arg1 (read-uint8 stream) arg2 (read-uint8 stream)) (error "Compound glyphs relative to indexes not yet supported"))) ;; Transform according to the transformation matrix (let ((a 1.0) (b 0.0) (c 0.0) (d 1.0) (e arg1) (f arg2)) (ecase (transform-option-count flags) (0) (1 (setf a (setf d (read-fixed2.14 stream)))) (2 (setf a (read-fixed2.14 stream) d (read-fixed2.14 stream))) (4 (setf a (read-fixed2.14 stream) b (read-fixed2.14 stream) c (read-fixed2.14 stream) d (read-fixed2.14 stream)))) (let ((transform-fn (make-transformer a b c d e f))) (transform-contours transform-fn contours))) (unless more-components-p (return (merge-contours contours-list))))))))) (defun read-points-vector (stream flags count axis) (let ((points (make-array count :fill-pointer 0)) (short-index (if (eql axis :x) 1 2)) (same-index (if (eql axis :x) 4 5))) (flet ((save-point (point) (vector-push point points))) (loop for flag across flags for short-p = (logbitp short-index flag) for same-p = (logbitp same-index flag) do (cond (short-p (let ((new-point (read-uint8 stream))) (save-point (if same-p new-point (- new-point))))) (t (if same-p (save-point 0) (save-point (read-int16 stream))))))) points)) (defun read-simple-contours (contour-count stream) "With the stream positioned immediately after the glyph bounding box, read the contours data from STREAM and return it as a vector." (let ((contour-endpoint-indexes (make-array contour-count))) (loop for i below contour-count for endpoint-index = (read-uint16 stream) do (setf (svref contour-endpoint-indexes i) endpoint-index)) ;; instructions (let ((n-points (1+ (svref contour-endpoint-indexes (1- contour-count)))) (instruction-length (read-uint16 stream))) (loop for i below instruction-length do (read-byte stream)) ;; read the flags (let ((flags (make-array n-points))) (loop with i = 0 while (< i n-points) do (let ((flag-byte (read-uint8 stream))) (setf (svref flags i) flag-byte) (incf i) (when (logbitp 3 flag-byte) (let ((n-repeats (read-uint8 stream))) (loop repeat n-repeats do (setf (svref flags i) flag-byte) (incf i)))))) (let ((x-points (read-points-vector stream flags n-points :x )) (y-points (read-points-vector stream flags n-points :y)) (control-points (make-array n-points :fill-pointer 0)) (contours (make-array contour-count))) (loop for x-point across x-points for y-point across y-points for flag across flags for x = x-point then (+ x x-point) for y = y-point then (+ y y-point) do (vector-push-extend (make-control-point x y (logbitp 0 flag)) control-points)) (loop for start = 0 then (1+ end) for end across contour-endpoint-indexes for i from 0 do (setf (svref contours i) (subseq control-points start (1+ end)))) contours))))) (defun read-contours-at-index (index loader) "Read the contours at glyph index INDEX, discarding bounding box information." (let ((stream (input-stream loader))) (file-position stream (+ (table-position "glyf" loader) (glyph-location index loader))) (let ((contour-count (read-int16 stream)) (xmin (read-int16 stream)) (ymin (read-int16 stream)) (xmax (read-int16 stream)) (ymax (read-int16 stream))) (declare (ignore xmin ymin xmax ymax)) (if (= contour-count -1) (read-compound-contours loader) (read-simple-contours contour-count stream))))) zpb-ttf-release-1.0.4/glyph.lisp000066400000000000000000000247621400112033600165350ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; An object for working with glyphs from the font. Some fields are ;;; lazily loaded from the input-stream of the font-loader when needed. ;;; ;;; $Id: glyph.lisp,v 1.28 2007/08/08 16:21:19 xach Exp $ (in-package #:zpb-ttf) (defclass glyph () ((font-loader :initarg :font-loader :reader font-loader :documentation "The font-loader from which this glyph originates.") (font-index :initarg :font-index :accessor font-index :documentation "The index of this glyph within the font file, used to look up information in various structures in the truetype file.") (code-point :initarg :code-point :accessor code-point) (contours :initarg :contours :accessor contours) (bounding-box :initarg :bounding-box :accessor bounding-box))) (defmethod initialize-instance :after ((glyph glyph) &key code-point font-index font-loader &allow-other-keys) (flet ((argument-error (name) (error "Missing required initarg ~S" name))) (unless font-loader (argument-error :font-loader)) (cond ((and code-point font-index)) ;; do nothing (code-point (setf (font-index glyph) (code-point-font-index code-point font-loader))) (font-index (let ((code-point (font-index-code-point font-index font-loader))) (when (zerop code-point) (setf code-point (or (postscript-name-code-point (postscript-name glyph)) code-point))) (setf (code-point glyph) code-point))) (t (argument-error (list :font-index :code-point)))))) (defmethod print-object ((glyph glyph) stream) (print-unreadable-object (glyph stream :type t :identity nil) ;; FIXME: Is this really going to be Unicode? (format stream "~S U+~4,'0X" (postscript-name glyph) (code-point glyph)))) ;;; Glyph-specific values determined from data in the font-loader (defgeneric left-side-bearing (object) (:method ((glyph glyph)) (bounded-aref (left-side-bearings (font-loader glyph)) (font-index glyph)))) (defmethod (setf left-side-bearing) (new-value glyph) (setf (bounded-aref (left-side-bearings (font-loader glyph)) (font-index glyph)) new-value)) ;;; Kerning (defgeneric kerning-offset (left right loader)) (defmethod kerning-offset ((left-glyph glyph) (right-glyph glyph) (font-loader font-loader)) (let ((kerning-table-key (logior (ash (font-index left-glyph) 16) (font-index right-glyph)))) (gethash kerning-table-key (kerning-table font-loader) 0))) (defmethod kerning-offset ((left character) (right character) (font-loader font-loader)) (kerning-offset (find-glyph left font-loader) (find-glyph right font-loader) font-loader)) (defmethod kerning-offset ((left null) right font-loader) (declare (ignore left right font-loader)) 0) (defmethod kerning-offset (left (right null) font-loader) (declare (ignore left right font-loader)) 0) (defgeneric advance-width (object) (:method ((glyph glyph)) (bounded-aref (advance-widths (font-loader glyph)) (font-index glyph)))) (defmethod (setf advance-width) (new-value (glyph glyph)) (setf (bounded-aref (advance-widths (font-loader glyph)) (font-index glyph)) new-value)) (defgeneric kerned-advance-width (object next) (:method ((object glyph) next) (+ (advance-width object) (kerning-offset object next (font-loader object))))) (defgeneric location (object) (:method ((glyph glyph)) (with-slots (font-index font-loader) glyph (+ (table-position "glyf" font-loader) (glyph-location font-index font-loader))))) (defgeneric data-size (object) (:method ((glyph glyph)) (with-slots (font-index font-loader) glyph (- (glyph-location (1+ font-index) font-loader) (glyph-location font-index font-loader))))) ;;; Initializing delayed data (defmethod initialize-bounding-box ((glyph glyph)) (if (zerop (data-size glyph)) (setf (bounding-box glyph) (empty-bounding-box)) (let ((stream (input-stream (font-loader glyph)))) ;; skip contour-count (file-position stream (+ (location glyph) 2)) (setf (bounding-box glyph) (vector (read-fword stream) (read-fword stream) (read-fword stream) (read-fword stream)))))) (defmethod initialize-contours ((glyph glyph)) (if (zerop (data-size glyph)) (setf (contours glyph) (empty-contours)) (let ((stream (input-stream (font-loader glyph)))) (file-position stream (location glyph)) (let ((contour-count (read-int16 stream))) ;; skip glyph bounding box, 4 FWords (advance-file-position stream 8) (if (= contour-count -1) (setf (contours glyph) (read-compound-contours (font-loader glyph))) (setf (contours glyph) (read-simple-contours contour-count stream))))))) (defmethod bounding-box :before ((glyph glyph)) (unless (slot-boundp glyph 'bounding-box) (initialize-bounding-box glyph))) (defmethod contours :before ((glyph glyph)) (unless (slot-boundp glyph 'contours) (initialize-contours glyph))) (defgeneric contour-count (object) (:method (object) (length (contours object)))) (defgeneric contour (object idex) (:method (object index) (aref (contours object) index))) (defmacro do-contours ((contour object &optional result) &body body) (let ((i (gensym)) (obj (gensym))) `(let ((,obj ,object)) (dotimes (,i (contour-count ,obj) ,result) (let ((,contour (contour ,obj ,i))) ,@body))))) (defgeneric right-side-bearing (object) (:method ((glyph glyph)) (- (advance-width glyph) (- (+ (left-side-bearing glyph) (xmax glyph)) (xmin glyph))))) ;;; Producing a bounding box for a sequence of characters (defgeneric string-bounding-box (string loader &key kerning)) (defmethod string-bounding-box (string (font-loader font-loader) &key (kerning t)) (cond ((zerop (length string)) (empty-bounding-box)) ((= 1 (length string)) (copy-seq (bounding-box (find-glyph (char string 0) font-loader)))) (t (let ((origin 0) (left (find-glyph (char string 0) font-loader)) (xmin most-positive-fixnum) (ymin most-positive-fixnum) (xmax most-negative-fixnum) (ymax most-negative-fixnum)) (flet ((update-bounds (glyph) (setf xmin (min (+ (xmin glyph) origin) xmin) xmax (max (+ (xmax glyph) origin) xmax) ymin (min (ymin glyph) ymin) ymax (max (ymax glyph) ymax)))) (update-bounds left) (loop for i from 1 below (length string) for glyph = (find-glyph (char string i) font-loader) do (incf origin (advance-width left)) (when kerning (incf origin (kerning-offset left glyph font-loader))) (setf left glyph) (update-bounds glyph))) (vector xmin ymin xmax ymax))))) ;;; Producing glyphs from loaders (defgeneric glyph-exists-p (character font-loader) (:method ((character glyph) font-loader) (let ((index (font-index character))) (not (zerop index)))) (:method (character font-loader) (glyph-exists-p (find-glyph character font-loader) font-loader))) (defgeneric find-glyph (character font-loader) (:documentation "Find the glyph object for CHARACTER in FONT-LOADER and return it. If CHARACTER is an integer, treat it as a Unicode code point. If CHARACTER is a Lisp character, treat its char-code as a Unicode code point.") (:method ((character integer) (font-loader font-loader)) (index-glyph (code-point-font-index character font-loader) font-loader)) (:method ((character character) (font-loader font-loader)) (find-glyph (char-code character) font-loader))) (defgeneric index-glyph (index font-loader) (:documentation "Return the GLYPH object located at glyph index INDEX in FONT-LOADER, or NIL if no glyph is defined for that index. Despite the name, NOT the inverse of GLYPH-INDEX.") (:method (index font-loader) (let* ((cache (glyph-cache font-loader)) (glyph (aref cache index))) (if glyph glyph (setf (aref cache index) (make-instance 'glyph :font-index index :font-loader font-loader)))))) ;;; Misc (defmethod postscript-name ((glyph glyph)) (let* ((names (postscript-glyph-names (font-loader glyph))) (index (font-index glyph)) (name (aref names index))) (cond (name) ((slot-boundp glyph 'code-point) (setf (aref names index) (format nil "uni~4,'0X" (code-point glyph)))) (t "unknown")))) zpb-ttf-release-1.0.4/head.lisp000066400000000000000000000060241400112033600163020ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; Loading data from the "head" table. ;;; ;;; https://docs.microsoft.com/en-us/typography/opentype/spec/head ;;; http://developer.apple.com/fonts/TTRefMan/RM06/Chap6head.html ;;; ;;; $Id: head.lisp,v 1.5 2006/02/18 23:13:43 xach Exp $ (in-package #:zpb-ttf) (defmethod load-head-info ((font-loader font-loader)) (seek-to-table "head" font-loader) (with-slots (input-stream units/em bounding-box loca-offset-format) font-loader (flet ((skip-bytes (count) (file-position input-stream (+ count (file-position input-stream))))) (let ((version (read-uint32 input-stream))) (check-version "\"head\" table" version #x00010000)) ;; skip fontRevsion and checkSumAdjustment (both uint32) (skip-bytes 8) ;; check the magicNumber (let ((magic-number (read-uint32 input-stream))) (when (/= magic-number #x5F0F3CF5) (error 'bad-magic :location "\"head\" table" :expected-values (list #x5F0F3CF5) :actual-value magic-number))) ;; skip flags (skip-bytes 2) (setf units/em (read-uint16 input-stream)) ;; skip created and modified dates (skip-bytes 16) (setf bounding-box (vector (read-int16 input-stream) (read-int16 input-stream) (read-int16 input-stream) (read-int16 input-stream))) ;; skip macStyle, lowestRecPPEM, fontDirectionHint (skip-bytes 6) ;; set the loca-offset-format (if (zerop (read-int16 input-stream)) (setf loca-offset-format :short) (setf loca-offset-format :long))))) zpb-ttf-release-1.0.4/hhea.lisp000066400000000000000000000044161400112033600163110ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; Loading data from the "hhea" table. ;;; ;;; https://docs.microsoft.com/en-us/typography/opentype/spec/hhea ;;; http://developer.apple.com/fonts/TTRefMan/RM06/Chap6hhea.html ;;; ;;; $Id: hhea.lisp,v 1.4 2006/02/18 23:13:43 xach Exp $ (in-package #:zpb-ttf) (defmethod load-hhea-info ((font-loader font-loader)) (seek-to-table "hhea" font-loader) (with-slots (input-stream ascender descender line-gap) font-loader (let ((version (read-fixed input-stream))) (check-version "\"hhea\" table" version #x00010000)) (setf ascender (read-fword input-stream) descender (read-fword input-stream) line-gap (read-fword input-stream)))) (defmethod horizontal-metrics-count ((font-loader font-loader)) (seek-to-table "hhea" font-loader) (with-slots (input-stream) font-loader ;; Skip to the end, since all we care about is the last item (advance-file-position input-stream 34) (read-uint16 input-stream))) zpb-ttf-release-1.0.4/hmtx.lisp000066400000000000000000000043341400112033600163630ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; Loading data from the "hmtx" table. ;;; ;;; https://docs.microsoft.com/en-us/typography/opentype/spec/hmtx ;;; http://developer.apple.com/fonts/TTRefMan/RM06/Chap6hmtx.html ;;; ;;; $Id: hmtx.lisp,v 1.3 2006/02/18 23:13:43 xach Exp $ (in-package #:zpb-ttf) (defmethod load-hmtx-info ((font-loader font-loader)) (let* ((horizontal-metrics-count (horizontal-metrics-count font-loader)) (advance-widths (make-array horizontal-metrics-count)) (left-side-bearings (make-array horizontal-metrics-count))) (seek-to-table "hmtx" font-loader) (with-slots (input-stream) font-loader (dotimes (i horizontal-metrics-count) (setf (svref advance-widths i) (read-uint16 input-stream)) (setf (svref left-side-bearings i) (read-int16 input-stream)))) (setf (advance-widths font-loader) advance-widths (left-side-bearings font-loader) left-side-bearings))) zpb-ttf-release-1.0.4/kern.lisp000066400000000000000000000102621400112033600163370ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; "kern" table functions ;;; ;;; https://docs.microsoft.com/en-us/typography/opentype/spec/kern ;;; http://developer.apple.com/fonts/TTRefMan/RM06/Chap6kern.html ;;; ;;; $Id: kern.lisp,v 1.8 2006/03/28 14:38:37 xach Exp $ (in-package #:zpb-ttf) (defun load-kerning-format-1 (table stream) "Return a hash table keyed on a UINT32 key that represents the glyph index in the left and right halves with a value of the kerning distance between the pair." (let ((pair-count (read-uint16 stream)) (search-range (read-uint16 stream)) (entry-selector (read-uint16 stream)) (range-shift (read-uint16 stream))) (declare (ignore search-range entry-selector range-shift)) (dotimes (i pair-count) (setf (gethash (read-uint32 stream) table) (read-int16 stream))))) (defmethod load-kerning-subtable ((font-loader font-loader) format) (when (/= 1 format) (error 'unsupported-format :description "kerning subtable" :size 1 :expected-values (list 1) :actual-value format)) (load-kerning-format-1 (kerning-table font-loader) (input-stream font-loader))) (defmethod load-kern-info ((font-loader font-loader)) (when (table-exists-p "kern" font-loader) (seek-to-table "kern" font-loader) (let* ((stream (input-stream font-loader)) (maybe-version (read-uint16 stream)) (maybe-table-count (read-uint16 stream)) (version 0) (table-count 0)) ;; These shenanegins are because Apple documents one style of ;; kern table and Microsoft documents another. This code ;; implements Microsoft's version. ;; See: ;; http://developer.apple.com/fonts/TTRefMan/RM06/Chap6kern.html ;; https://docs.microsoft.com/en-us/typography/opentype/spec/kern (if (zerop version) (setf version maybe-version table-count maybe-table-count) (setf version (logand (ash maybe-version 16) maybe-table-count) table-count (read-uint32 stream))) (check-version "\"kern\" table" version 0) (dotimes (i table-count) (let ((version (read-uint16 stream)) (length (read-uint16 stream)) (coverage-flags (read-uint8 stream)) (format (read-uint8 stream))) (declare (ignore version length coverage-flags)) (load-kerning-subtable font-loader format)))))) (defmethod all-kerning-pairs ((font-loader font-loader)) (let ((pairs nil)) (maphash (lambda (k v) (let* ((left-index (ldb (byte 16 16) k)) (right-index (ldb (byte 16 0) k)) (left (index-glyph left-index font-loader)) (right (index-glyph right-index font-loader))) (push (list left right v) pairs))) (kerning-table font-loader)) pairs)) zpb-ttf-release-1.0.4/loca.lisp000066400000000000000000000045111400112033600163160ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; Loading data from the "loca" table. ;;; ;;; https://docs.microsoft.com/en-us/typography/opentype/spec/loca ;;; http://developer.apple.com/fonts/TTRefMan/RM06/Chap6loca.html ;;; ;;; $Id: loca.lisp,v 1.3 2006/02/18 23:13:43 xach Exp $ (in-package #:zpb-ttf) (defmethod load-loca-info ((font-loader font-loader)) (seek-to-table "loca" font-loader) (with-slots (input-stream glyph-locations glyph-count loca-offset-format) font-loader (setf glyph-locations (make-array (1+ glyph-count))) (dotimes (i (1+ glyph-count)) (setf (svref glyph-locations i) (if (eql loca-offset-format :short) (* (read-uint16 input-stream) 2) (read-uint32 input-stream)))))) (defmethod glyph-location (index (font-loader font-loader)) (aref (glyph-locations font-loader) index)) (defmethod glyph-length (index (font-loader font-loader)) (with-slots (glyph-locations) font-loader (- (aref glyph-locations (1+ index)) (aref glyph-locations index)))) zpb-ttf-release-1.0.4/maxp.lisp000066400000000000000000000036071400112033600163520ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; Loading data from the "maxp" table. ;;; ;;; https://docs.microsoft.com/en-us/typography/opentype/spec/maxp ;;; http://developer.apple.com/fonts/TTRefMan/RM06/Chap6maxp.html ;;; ;;; $Id: maxp.lisp,v 1.3 2006/02/18 23:13:43 xach Exp $ (in-package #:zpb-ttf) (defmethod load-maxp-info ((font-loader font-loader)) (seek-to-table "maxp" font-loader) (with-slots (input-stream glyph-count) font-loader (let ((version (read-uint32 input-stream))) (check-version "\"maxp\" table" version #x00010000) (setf glyph-count (read-uint16 input-stream))))) zpb-ttf-release-1.0.4/name.lisp000066400000000000000000000354261400112033600163310ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; Loading data from the TrueType "name" table. ;;; ;;; https://docs.microsoft.com/en-us/typography/opentype/spec/name ;;; http://developer.apple.com/fonts/TTRefMan/RM06/Chap6name.html ;;; ;;; $Id: name.lisp,v 1.8 2006/02/18 23:13:43 xach Exp $ (in-package #:zpb-ttf) (defvar *name-identifiers* #(:copyright-notice :font-family :font-subfamily :unique-subfamily :full-name :name-table-version :postscript-name :trademark-notice :manufacturer-name :designer :description :vendor-url :designer-url :license-description :licence-info-url :reserved :preferred-family :preferred-subfamily :compatible-full :sample-text)) (defvar *platform-identifiers* #(:unicode :macintosh :iso :microsoft :custom)) (defvar *unicode-encoding-ids* #(:unicode-1.0 :unicode-1.1 :iso-10646\:1993 :unicode>=2.0-bmp-only :unicode>=2.0-full-repertoire)) (defvar *microsoft-encoding-ids* #(:symbol :unicode :shiftjis :prc :big5 :wansung :johab :reserved :reserved :reserved :ucs-4)) (defvar *macintosh-encoding-ids* #(:roman :japanese :chinese-traditional :korean :arabic :hebrew :greek :russian :RSymbol :devanagari :gurmukhi :gujarati :oriya :bengali :tamil :telugu :kennada :malayam :sinhalese :burmese :khmer :thai :laotian :georgian :armenian :chinese-simplified :tibetan :mongolian :geez :slavic :vietnamese :sindhi :uninterpreted)) (defparameter *encoding-tables* (vector *unicode-encoding-ids* *macintosh-encoding-ids* nil *microsoft-encoding-ids* nil)) (defun encoding-id-name (platform-id encoding-id) (aref (aref *encoding-tables* platform-id) encoding-id)) (defun platform-id-name (platform-id) (aref *platform-identifiers* platform-id)) (defparameter *macroman-translation-table* #(#x00 #x00 #x01 #x01 #x02 #x02 #x03 #x03 #x04 #x04 #x05 #x05 #x06 #x06 #x07 #x07 #x08 #x08 #x09 #x09 #x0A #x0A #x0B #x0B #x0C #x0C #x0D #x0D #x0E #x0E #x0F #x0F #x10 #x10 #x11 #x11 #x12 #x12 #x13 #x13 #x14 #x14 #x15 #x15 #x16 #x16 #x17 #x17 #x18 #x18 #x19 #x19 #x1A #x1A #x1B #x1B #x1C #x1C #x1D #x1D #x1E #x1E #x1F #x1F #x20 #x20 #x21 #x21 #x22 #x22 #x23 #x23 #x24 #x24 #x25 #x25 #x26 #x26 #x27 #x27 #x28 #x28 #x29 #x29 #x2A #x2A #x2B #x2B #x2C #x2C #x2D #x2D #x2E #x2E #x2F #x2F #x30 #x30 #x31 #x31 #x32 #x32 #x33 #x33 #x34 #x34 #x35 #x35 #x36 #x36 #x37 #x37 #x38 #x38 #x39 #x39 #x3A #x3A #x3B #x3B #x3C #x3C #x3D #x3D #x3E #x3E #x3F #x3F #x40 #x40 #x41 #x41 #x42 #x42 #x43 #x43 #x44 #x44 #x45 #x45 #x46 #x46 #x47 #x47 #x48 #x48 #x49 #x49 #x4A #x4A #x4B #x4B #x4C #x4C #x4D #x4D #x4E #x4E #x4F #x4F #x50 #x50 #x51 #x51 #x52 #x52 #x53 #x53 #x54 #x54 #x55 #x55 #x56 #x56 #x57 #x57 #x58 #x58 #x59 #x59 #x5A #x5A #x5B #x5B #x5C #x5C #x5D #x5D #x5E #x5E #x5F #x5F #x60 #x60 #x61 #x61 #x62 #x62 #x63 #x63 #x64 #x64 #x65 #x65 #x66 #x66 #x67 #x67 #x68 #x68 #x69 #x69 #x6A #x6A #x6B #x6B #x6C #x6C #x6D #x6D #x6E #x6E #x6F #x6F #x70 #x70 #x71 #x71 #x72 #x72 #x73 #x73 #x74 #x74 #x75 #x75 #x76 #x76 #x77 #x77 #x78 #x78 #x79 #x79 #x7A #x7A #x7B #x7B #x7C #x7C #x7D #x7D #x7E #x7E #x7F #x7F #x80 #x00C4 #x81 #x00C5 #x82 #x00C7 #x83 #x00C9 #x84 #x00D1 #x85 #x00D6 #x86 #x00DC #x87 #x00E1 #x88 #x00E0 #x89 #x00E2 #x8A #x00E4 #x8B #x00E3 #x8C #x00E5 #x8D #x00E7 #x8E #x00E9 #x8F #x00E8 #x90 #x00EA #x91 #x00EB #x92 #x00ED #x93 #x00EC #x94 #x00EE #x95 #x00EF #x96 #x00F1 #x97 #x00F3 #x98 #x00F2 #x99 #x00F4 #x9A #x00F6 #x9B #x00F5 #x9C #x00FA #x9D #x00F9 #x9E #x00FB #x9F #x00FC #xA0 #x2020 #xA1 #x00B0 #xA2 #x00A2 #xA3 #x00A3 #xA4 #x00A7 #xA5 #x2022 #xA6 #x00B6 #xA7 #x00DF #xA8 #x00AE #xA9 #x00A9 #xAA #x2122 #xAB #x00B4 #xAC #x00A8 #xAD #x2260 #xAE #x00C6 #xAF #x00D8 #xB0 #x221E #xB1 #x00B1 #xB2 #x2264 #xB3 #x2265 #xB4 #x00A5 #xB5 #x00B5 #xB6 #x2202 #xB7 #x2211 #xB8 #x220F #xB9 #x03C0 #xBA #x222B #xBB #x00AA #xBC #x00BA #xBD #x03A9 #xBE #x00E6 #xBF #x00F8 #xC0 #x00BF #xC1 #x00A1 #xC2 #x00AC #xC3 #x221A #xC4 #x0192 #xC5 #x2248 #xC6 #x2206 #xC7 #x00AB #xC8 #x00BB #xC9 #x2026 #xCA #x00A0 #xCB #x00C0 #xCC #x00C3 #xCD #x00D5 #xCE #x0152 #xCF #x0153 #xD0 #x2103 #xD1 #x2014 #xD2 #x201C #xD3 #x201D #xD4 #x2018 #xD5 #x2019 #xD6 #x00F7 #xD7 #x25CA #xD8 #x00FF #xD9 #x0178 #xDA #x2044 #xDB #x20AC #xDC #x2039 #xDD #x203A #xDE #xFB01 #xDF #xFB02 #xE0 #x2021 #xE1 #x00B7 #xE2 #x201A #xE3 #x201E #xE4 #x2030 #xE5 #x00C2 #xE6 #x00CA #xE7 #x00C1 #xE8 #x00CB #xE9 #x00C8 #xEA #x00CD #xEB #x00CE #xEC #x00CF #xED #x00CC #xEE #x00D3 #xEF #x00D4 #xF0 #xF8FF #xF1 #x00D2 #xF2 #x00DA #xF3 #x00DB #xF4 #x00D9 #xF5 #x0131 #xF6 #x02C6 #xF7 #x02DC #xF8 #x00AF #xF9 #x02D8 #xFA #x02D9 #xFB #x02DA #xFC #x00B8 #xFD #x02DD #xFE #x02DB #xFF #x02C7)) (defconstant +unicode-platform-id+ 0) (defconstant +macintosh-platform-id+ 1) (defconstant +iso-platform-id+ 2) (defconstant +microsoft-platform-id+ 3) (defconstant +custom-platform-id+ 4) (defconstant +unicode-2.0-encoding-id+ 3) (defconstant +microsoft-unicode-bmp-encoding-id+ 1) (defconstant +microsoft-symbol-encoding-id+ 0) (defconstant +macintosh-roman-encoding-id+ 1) ;; Full list of microsoft language IDs is here: ;; http://www.microsoft.com/globaldev/reference/lcid-all.mspx (defconstant +microsoft-us-english-language-id+ #x0409) (defconstant +macintosh-english-language-id+ 1) (defconstant +unicode-language-id+ 0) (defclass name-entry () ((font-loader :initarg :font-loader :accessor font-loader) (platform-id :initarg :platform-id :accessor platform-id) (encoding-id :initarg :encoding-id :accessor encoding-id) (language-id :initarg :language-id :accessor language-id) (name-id :initarg :name-id :accessor name-id) (offset :initarg :offset :accessor offset :documentation "The octet offset within the TrueType file stream of the entry's data. *Not* the same as the offset in the NameRecord structure, which is relative to the start of the string data for the table.") (entry-length :initarg :entry-length :accessor entry-length) (value :reader %value :writer (setf value)) (octets :reader %octets :writer (setf octets)))) (defmethod print-object ((name-entry name-entry) stream) (print-unreadable-object (name-entry stream :type t) (format stream "~A (~A/~A/~D)" (aref *name-identifiers* (name-id name-entry)) (platform-id-name (platform-id name-entry)) (encoding-id-name (platform-id name-entry) (encoding-id name-entry)) (language-id name-entry)))) (defun unicode-octets-to-string (octets) (let ((string (make-string (/ (length octets) 2)))) (flet ((ref16 (i) (+ (ash (aref octets i) 16) (aref octets (1+ i))))) (loop for i from 0 below (length octets) by 2 for j from 0 do (setf (char string j) (code-char (ref16 i)))) string))) (defun macintosh-octets-to-string (octets) (flet ((macroman->unicode (point) (code-char (aref *macroman-translation-table* (1+ (ash point 1)))))) (let ((string (make-string (length octets)))) (dotimes (i (length octets) string) (setf (schar string i) (macroman->unicode (aref octets i))))))) (defgeneric initialize-name-entry (name-entry) (:method (name-entry) (let ((stream (input-stream (font-loader name-entry))) (octets (make-array (entry-length name-entry) :element-type '(unsigned-byte 8))) (value nil) (platform-id (platform-id name-entry))) (file-position stream (offset name-entry)) (read-sequence octets stream) (cond ((or (= platform-id +unicode-platform-id+) (= platform-id +microsoft-platform-id+)) (setf value (unicode-octets-to-string octets))) ((= platform-id +macintosh-platform-id+) (setf value (macintosh-octets-to-string octets))) (t (error 'unsupported-value :location "\"name\" table platform ID" :actual-value platform-id :expected-values (list +unicode-platform-id+ +microsoft-platform-id+ +macintosh-platform-id+)))) (setf (value name-entry) value (octets name-entry) octets)))) (defgeneric value (name-entry) (:method (name-entry) (unless (slot-boundp name-entry 'value) (initialize-name-entry name-entry)) (%value name-entry))) (defgeneric octets (name-entry) (:method (name-entry) (unless (slot-boundp name-entry 'octets) (initialize-name-entry name-entry)) (%octets name-entry))) (defun load-name-info (loader) (seek-to-table "name" loader) (let* ((stream (input-stream loader)) (table-offset (file-position stream)) (format (read-uint16 stream))) (unless (= format 0) (error 'unsupported-format :location "\"name\" table" :actual-value format :expected-values (list 0))) (let* ((count (read-uint16 stream)) (values-offset (read-uint16 stream)) (entries (make-array count))) (setf (name-entries loader) entries) (dotimes (i count) (let ((platform-id (read-uint16 stream)) (encoding-id (read-uint16 stream)) (language-id (read-uint16 stream)) (name-id (read-uint16 stream)) (length (read-uint16 stream)) (offset (read-uint16 stream))) (setf (aref entries i) (make-instance 'name-entry :font-loader loader :platform-id platform-id :encoding-id encoding-id :language-id language-id :name-id name-id :entry-length length :offset (+ table-offset values-offset offset)))))))) ;;; ;;; Fetching info out of the name-entry vector ;;; (defun name-identifier-id (symbol) (let ((id (position symbol *name-identifiers*))) (if id id (error "Unknown NAME identifier: ~S" symbol)))) (defmethod find-name-entry (platform-id encoding-id language-id name-id (font-loader font-loader)) ;; FIXME: this vector is sorted by platform ID, encoding ID, ;; language ID, and name ID, in that order. Could bisect if it ;; mattered. (loop for name-entry across (name-entries font-loader) when (and (or (null platform-id) (= (platform-id name-entry) platform-id)) (or (null encoding-id) (= (encoding-id name-entry) encoding-id)) (or (null language-id) (= (language-id name-entry) language-id)) (or (null name-id) (= (name-id name-entry) name-id))) return name-entry)) (defmethod name-entry-value (name-designator (font-loader font-loader)) (let* ((name-id (etypecase name-designator (keyword (name-identifier-id name-designator)) (integer name-designator))) (entry (or (find-name-entry +unicode-platform-id+ +unicode-2.0-encoding-id+ +unicode-language-id+ name-id font-loader) (find-name-entry +microsoft-platform-id+ nil +microsoft-us-english-language-id+ name-id font-loader) (find-name-entry +macintosh-platform-id+ +macintosh-roman-encoding-id+ +macintosh-english-language-id+ name-id font-loader)))) (when entry (value entry)))) (defmethod postscript-name ((font-loader font-loader)) (name-entry-value :postscript-name font-loader)) (defmethod family-name ((font-loader font-loader)) (name-entry-value :font-family font-loader)) (defmethod subfamily-name ((font-loader font-loader)) (name-entry-value :font-subfamily font-loader)) (defmethod full-name ((font-loader font-loader)) (name-entry-value :full-name font-loader)) zpb-ttf-release-1.0.4/package.lisp000066400000000000000000000047331400112033600170010ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; $Id: package.lisp,v 1.22 2006/03/27 21:57:37 xach Exp $ (defpackage #:zpb-ttf (:use #:cl) (:export ;; font loader #:open-font-loader #:close-font-loader #:with-font-loader #:glyph-count #:name-entry-value #:find-name-entry #:value #:collection-font-count #:collection-font-index ;; font typographic #:italic-angle #:underline-thickness #:underline-position #:fixed-pitch-p #:units/em #:ascender #:descender #:line-gap ;; other font attributes #:postscript-name #:full-name #:family-name #:subfamily-name #:all-kerning-pairs #:glyph-exists-p #:index-glyph #:find-glyph ;; shared between font-loader and glyph #:bounding-box #:xmin #:ymin #:xmax #:ymax ;; control points #:x #:y #:on-curve-p ;; glyph contours #:contour-count #:contour #:contours #:do-contours #:explicit-contour-points #:do-contour-segments #:do-contour-segments* ;; glyph other #:code-point #:font-index ;; glyph typographic #:advance-width #:left-side-bearing #:right-side-bearing #:kerning-offset #:string-bounding-box)) zpb-ttf-release-1.0.4/post.lisp000066400000000000000000000202271400112033600163670ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; "post" table functions ;;; ;;; https://docs.microsoft.com/en-us/typography/opentype/spec/post ;;; http://developer.apple.com/fonts/TTRefMan/RM06/Chap6post.html ;;; ;;; $Id: post.lisp,v 1.7 2006/11/09 15:06:16 xach Exp $ (in-package #:zpb-ttf) (defvar *standard-mac-glyph-names* #(".notdef" ".null" "nonmarkingreturn" "space" "exclam" "quotedbl" "numbersign" "dollar" "percent" "ampersand" "quotesingle" "parenleft" "parenright" "asterisk" "plus" "comma" "hyphen" "period" "slash" "zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" "colon" "semicolon" "less" "equal" "greater" "question" "at" "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" "bracketleft" "backslash" "bracketright" "asciicircum" "underscore" "grave" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "braceleft" "bar" "braceright" "asciitilde" "Adieresis" "Aring" "Ccedilla" "Eacute" "Ntilde" "Odieresis" "Udieresis" "aacute" "agrave" "acircumflex" "adieresis" "atilde" "aring" "ccedilla" "eacute" "egrave" "ecircumflex" "edieresis" "iacute" "igrave" "icircumflex" "idieresis" "ntilde" "oacute" "ograve" "ocircumflex" "odieresis" "otilde" "uacute" "ugrave" "ucircumflex" "udieresis" "dagger" "degree" "cent" "sterling" "section" "bullet" "paragraph" "germandbls" "registered" "copyright" "trademark" "acute" "dieresis" "notequal" "AE" "Oslash" "infinity" "plusminus" "lessequal" "greaterequal" "yen" "mu" "partialdiff" "summation" "product" "pi" "integral" "ordfeminine" "ordmasculine" "Omega" "ae" "oslash" "questiondown" "exclamdown" "logicalnot" "radical" "florin" "approxequal" "Delta" "guillemotleft" "guillemotright" "ellipsis" "nonbreakingspace" "Agrave" "Atilde" "Otilde" "OE" "oe" "endash" "emdash" "quotedblleft" "quotedblright" "quoteleft" "quoteright" "divide" "lozenge" "ydieresis" "Ydieresis" "fraction" "currency" "guilsinglleft" "guilsinglright" "fi" "fl" "daggerdbl" "periodcentered" "quotesinglbase" "quotedblbase" "perthousand" "Acircumflex" "Ecircumflex" "Aacute" "Edieresis" "Egrave" "Iacute" "Icircumflex" "Idieresis" "Igrave" "Oacute" "Ocircumflex" "apple" "Ograve" "Uacute" "Ucircumflex" "Ugrave" "dotlessi" "circumflex" "tilde" "macron" "breve" "dotaccent" "ring" "cedilla" "hungarumlaut" "ogonek" "caron" "Lslash" "lslash" "Scaron" "scaron" "Zcaron" "zcaron" "brokenbar" "Eth" "eth" "Yacute" "yacute" "Thorn" "thorn" "minus" "multiply" "onesuperior" "twosuperior" "threesuperior" "onehalf" "onequarter" "threequarters" "franc" "Gbreve" "gbreve" "Idotaccent" "Scedilla" "scedilla" "Cacute" "cacute" "Ccaron" "ccaron" "dcroat")) (defun load-post-format-2 (names stream size-without-header) (let* ((standard-names *standard-mac-glyph-names*) (name-count (length names)) (glyph-count (read-uint16 stream))) (when (/= glyph-count name-count) (warn "Glyph count in \"post\" table (~D) ~ does not match glyph count in \"maxp\" table (~D). ~ This font may be broken." glyph-count name-count) (setf glyph-count name-count)) ;; This is done in a couple passes. First, initialize the names ;; tables with indexes into either the standard table or the ;; pstring table. (dotimes (i glyph-count) (setf (aref names i) (read-uint16 stream))) ;; Next, read the pstring table into a vector. ;; We can't know the number of extended glyph names in advance but ;; GLYPH-COUNT should be enough in many cases. Note that we cannot ;; compute the number of extended glyph names from the indices ;; preceding the indices might not reference all names. (let ((pstrings (make-array glyph-count :adjustable t :fill-pointer 0))) (loop with position = (+ 2 (* 2 glyph-count)) while (< position size-without-header) do (let ((string (read-pstring stream))) (vector-push-extend string pstrings) (incf position (1+ (length string))))) ;; Finally, replace the indexes with names. (loop for i below glyph-count for name-index across names do (setf (aref names i) (if (< name-index 258) (aref standard-names name-index) (aref pstrings (- name-index 258)))))))) (defun load-post-format-3 (names stream) (declare (ignore stream)) (fill names nil)) (defmethod load-post-info ((font-loader font-loader)) (let* ((names (make-array (glyph-count font-loader) :initial-element 0)) (stream (input-stream font-loader)) (table-info (table-info "post" font-loader))) (seek-to-table table-info font-loader) (let ((format (read-uint32 stream)) (header-size 32)) (when (/= format #x00020000 #x00030000) (error 'unsupported-format :location "\"post\" table" :expected-values (list #x00020000 #x00030000) :actual-value format)) (setf (italic-angle font-loader) (read-fixed stream) (underline-position font-loader) (read-fword stream) (underline-thickness font-loader) (read-fword stream) (fixed-pitch-p font-loader) (plusp (read-uint32 stream)) (postscript-glyph-names font-loader) names) ;; skip minMemType* fields (advance-file-position stream (- header-size 16)) (case format (#x00020000 (load-post-format-2 names stream (- (size table-info) header-size))) (#x00030000 (load-post-format-3 names stream)))))) (defun postscript-uni-name-p (name) (let ((end (or (position #\. name) (length name)))) (and (= end 7) (= (mismatch "uni" name) 3) (loop for i from 3 below end always (digit-char-p (char name i) 16))))) (defun postscript-name-code-point (name) "Returns, if available, the interpretation of the PostScript name NAME as a Unicode code point specifier. Ref: http://partners.adobe.com/public/developer/opentype/index_glyph.html" (when (postscript-uni-name-p name) (parse-integer name :start 3 :end 7 :radix 16))) zpb-ttf-release-1.0.4/util.lisp000066400000000000000000000071421400112033600163600ustar00rootroot00000000000000;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; ;;; Utility functions, mostly for reading data out of the input-stream ;;; of a font-loader. ;;; ;;; $Id: util.lisp,v 1.9 2006/02/18 23:13:43 xach Exp $ (in-package #:zpb-ttf) ;;; Reading compound MSB values from an '(unsigned-byte 8) stream (defun read-uint32 (stream) (loop repeat 4 for value = (read-byte stream) then (logior (ash value 8) (read-byte stream)) finally (return value))) (defun read-uint16 (stream) (loop repeat 2 for value = (read-byte stream) then (logior (ash value 8) (read-byte stream)) finally (return value))) (defun read-uint8 (stream) (read-byte stream)) (defun read-int8 (stream) (let ((result (read-byte stream))) (if (logbitp 7 result) (1- (- (logandc2 #xFF result))) result))) (defun read-int16 (stream) (let ((result (read-uint16 stream))) (if (logbitp 15 result) (1- (- (logandc2 #xFFFF result))) result))) (defun read-fixed (stream) (read-uint32 stream)) (defun read-fword (stream) (read-int16 stream)) (defun read-fixed2.14 (stream) (let ((value (read-uint16 stream))) (let ((integer (ash value -14)) (fraction (logand #x3FFF value))) (when (logbitp 1 integer) (setf integer (1- (- (logandc2 #b11 integer))))) (+ integer (float (/ fraction #x3FFF)))))) (defun read-pstring (stream) "Read a Pascal-style length-prefixed string." (let* ((length (read-uint8 stream)) (buf (make-array length :element-type '(unsigned-byte 8))) (string (make-string length))) (read-sequence buf stream) ;; The following could be (map 'string #'code-char buf), but that ;; form benchmarked poorly (dotimes (i length string) (setf (schar string i) (code-char (aref buf i)))))) (defun advance-file-position (stream n) "Move the file position of STREAM ahead by N bytes." (let ((pos (file-position stream))) (file-position stream (+ pos n)))) (defun bounded-aref (vector index) "Some TrueType data vectors are truncated, and any references beyond the end of the vector should be treated as a reference to the last element in the vector." (aref vector (min (1- (length vector)) index))) (defun (setf bounded-aref) (new-value vector index) (setf (aref vector (min (1- (length vector)) index)) new-value)) zpb-ttf-release-1.0.4/zpb-ttf.asd000066400000000000000000000071751400112033600165770ustar00rootroot00000000000000;; $Id: zpb-ttf.asd,v 1.5 2006/03/24 20:47:27 xach Exp $ (defpackage #:zpb-ttf-system (:use #:cl #:asdf)) (in-package #:zpb-ttf-system) (defsystem #:zpb-ttf :version "1.0.3" :author "Zach Beane " :description "Access TrueType font metrics and outlines from Common Lisp" :license "BSD" :components ((:file "package") (:file "util" :depends-on ("package")) (:file "conditions" :depends-on ("package")) (:file "bounding-box" :depends-on ("package")) (:file "font-loader" :depends-on ("package" "util" "bounding-box")) (:file "maxp" :depends-on ("package" "util" "font-loader")) (:file "head" :depends-on ("package" "util" "conditions" "font-loader")) (:file "kern" :depends-on ("package" "util" "conditions" "font-loader")) (:file "loca" :depends-on ("package" "util" "font-loader")) (:file "name" :depends-on ("package" "util" "conditions" "font-loader")) (:file "cmap" :depends-on ("package" "util" "name" "font-loader")) (:file "post" :depends-on ("package" "util" "conditions" "font-loader")) (:file "hhea" :depends-on ("package" "util" "font-loader")) (:file "hmtx" :depends-on ("package" "util" "font-loader" "hhea")) (:file "glyf" :depends-on ("package" "util" "loca" "font-loader")) (:file "glyph" :depends-on ("package" "util" "font-loader" "bounding-box" "glyf" "kern" "loca")) (:file "font-loader-interface" :depends-on ("package" "util" "conditions" "font-loader" "maxp" "head" "kern" "loca" "name" "cmap" "post" "hhea" "hmtx"))))