font-loader.lisp

   1 ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved
   2 ;;;
   3 ;;; Redistribution and use in source and binary forms, with or without
   4 ;;; modification, are permitted provided that the following conditions
   5 ;;; are met:
   6 ;;;
   7 ;;;   * Redistributions of source code must retain the above copyright
   8 ;;;     notice, this list of conditions and the following disclaimer.
   9 ;;;
  10 ;;;   * Redistributions in binary form must reproduce the above
  11 ;;;     copyright notice, this list of conditions and the following
  12 ;;;     disclaimer in the documentation and/or other materials
  13 ;;;     provided with the distribution.
  14 ;;;
  15 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  16 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  17 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  18 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  19 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  20 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  21 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  22 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  23 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  24 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  25 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  26 ;;;
  27 ;;; The font-loader object, which is the primary interface for
  28 ;;; getting glyph and metrics info.
  29 ;;;
  30 ;;; $Id: font-loader.lisp,v 1.26 2006/03/23 22:21:40 xach Exp $
  31
  32 (in-package #:zpb-ttf)
  33
  34 (defclass font-loader ()
  35   ((tables :initform (make-hash-table) :reader tables)
  36    (input-stream :initarg :input-stream :accessor input-stream
  37           :documentation "The stream from which things are loaded.")
  38    (table-count :initarg :table-count :reader table-count)
  39    ;; from the 'head' table
  40    (units/em :accessor units/em)
  41    (bounding-box :accessor bounding-box)
  42    (loca-offset-format :accessor loca-offset-format)
  43    ;; from the 'loca' table
  44    (glyph-locations :accessor glyph-locations)
  45    ;; from the 'cmap' table
  46    (character-map :accessor character-map)
  47    (inverse-character-map :accessor inverse-character-map)
  48    ;; from the 'maxp' table
  49    (glyph-count :accessor glyph-count)
  50    ;; from the 'hhea' table
  51    (ascender :accessor ascender)
  52    (descender :accessor descender)
  53    (line-gap :accessor line-gap)
  54    (max-width :accessor max-width)
  55    ;; from the 'hmtx' table
  56    (advance-widths :accessor advance-widths)
  57    (left-side-bearings :accessor left-side-bearings)
  58    ;; from the 'vhea' table
  59    (vhea-missing-p :initform nil :accessor vhea-missing-p)
  60    (vascender :accessor vascender)
  61    (vdescender :accessor vascender)
  62    ;; from 'vhea' and 'vmtx' tables
  63    (vmtx-missing-p :initform nil :accessor vmtx-missing-p)
  64    (advance-heights :accessor advance-heights)
  65    (top-side-bearings :accessor top-side-bearings)
  66    ;; from the 'kern' table
  67    (kerning-table :initform (make-hash-table) :accessor kerning-table)
  68    ;; from the 'name' table
  69    (name-entries :initform nil :accessor name-entries)
  70    ;; from the 'post' table
  71    (italic-angle :accessor italic-angle :initform 0)
  72    (fixed-pitch-p :accessor fixed-pitch-p :initform nil)
  73    (underline-position :accessor underline-position :initform 0)
  74    (underline-thickness :accessor underline-thickness :initform 0)
  75    (postscript-glyph-names :accessor postscript-glyph-names)
  76    ;; misc
  77    (glyph-cache :accessor glyph-cache)
  78    ;; # of fonts in collection, if loaded from a ttc file
  79    (collection-font-count :reader collection-font-count :initform nil
  80                           :initarg :collection-font-cont)
  81    ;; index of font in collection, if loaded from a ttc file
  82    (collection-font-index :reader collection-font-index :initform nil
  83                           :initarg :collection-font-index)))
  84
  85 (defclass table-info ()
  86   ((name :initarg :name :reader name)
  87    (offset :initarg :offset :reader offset)
  88    (size :initarg :size :reader size)))
  89
  90 (defmethod print-object ((object table-info) stream)
  91   (print-unreadable-object (object stream :type t)
  92     (format stream "\"~A\"" (name object))))
  93
  94 \f
  95 ;;; tag integers to strings and back
  96
  97 (defun number->tag (number)
  98   "Convert the 32-bit NUMBER to a string of four characters based on
  99 the CODE-CHAR of each octet in the number."
 100   (let ((tag (make-string 4)))
 101     (loop for i below 4
 102           for offset from 24 downto 0 by 8
 103           do (setf (schar tag i)
 104                    (code-char (ldb (byte 8 offset) number))))
 105     tag))
 106
 107 (defun tag->number (tag)
 108   "Convert the four-character string TAG to a 32-bit number based on
 109 the CHAR-CODE of each character."
 110   (declare (simple-string tag))
 111   (loop for char across tag
 112         for offset from 24 downto 0 by 8
 113         summing (ash (char-code char) offset)))
 114
 115 \f
 116 ;;; Getting table info out of the loader
 117
 118 (defmethod table-info ((tag string) (font-loader font-loader))
 119   (gethash (tag->number tag) (tables font-loader)))
 120
 121 (defmethod table-exists-p (tag font-loader)
 122   (nth-value 1 (table-info tag font-loader)))
 123
 124 (defmethod table-position ((tag string) (font-loader font-loader))
 125   "Return the byte position in the font-loader's stream for the table
 126 named by TAG."
 127   (let ((table-info (table-info tag font-loader)))
 128     (if table-info
 129         (offset table-info)
 130         (error "No such table -- ~A" tag))))
 131
 132 (defmethod table-size ((tag string) (font-loader font-loader))
 133   (let ((table-info (table-info tag font-loader)))
 134     (if table-info
 135         (size table-info)
 136         (error "No such table -- ~A" tag))))
 137
 138 (defmethod seek-to-table ((tag string) (font-loader font-loader))
 139   "Move FONT-LOADER's input stream to the start of the table named by TAG."
 140   (let ((table-info (table-info tag font-loader)))
 141     (if table-info
 142         (seek-to-table table-info font-loader)
 143         (error "No such table -- ~A" tag))))
 144
 145 (defmethod seek-to-table ((table table-info) (font-loader font-loader))
 146   "Move FONT-LOADER's input stream to the start of TABLE."
 147   (file-position (input-stream font-loader) (offset table)))