glyph.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 ;;; An object for working with glyphs from the font. Some fields are
  28 ;;; lazily loaded from the input-stream of the font-loader when needed.
  29 ;;;
  30 ;;; $Id: glyph.lisp,v 1.28 2007/08/08 16:21:19 xach Exp $
  31
  32 (in-package #:zpb-ttf)
  33
  34 (defclass glyph ()
  35   ((font-loader
  36     :initarg :font-loader
  37     :reader font-loader
  38     :documentation "The font-loader from which this glyph originates.")
  39    (font-index
  40     :initarg :font-index
  41     :accessor font-index
  42     :documentation "The index of this glyph within the font file, used
  43 to look up information in various structures in the truetype file.")
  44    (code-point
  45     :initarg :code-point
  46     :accessor code-point)
  47    (contours
  48     :initarg :contours
  49     :accessor contours)
  50    (bounding-box
  51     :initarg :bounding-box
  52     :accessor bounding-box)))
  53
  54 (defmethod initialize-instance :after ((glyph glyph)
  55                                        &key code-point font-index font-loader
  56                                        &allow-other-keys)
  57   (flet ((argument-error (name)
  58            (error "Missing required initarg ~S" name)))
  59     (unless font-loader
  60       (argument-error :font-loader))
  61     (cond ((and code-point font-index))  ;; do nothing
  62           (code-point
  63            (setf (font-index glyph)
  64                  (code-point-font-index code-point font-loader)))
  65           (font-index
  66            (let ((code-point (font-index-code-point font-index font-loader)))
  67              (when (zerop code-point)
  68                (setf code-point
  69                      (or (postscript-name-code-point (postscript-name glyph))
  70                          code-point)))
  71              (setf (code-point glyph) code-point)))
  72           (t
  73            (argument-error (list :font-index :code-point))))))
  74
  75 (defmethod print-object ((glyph glyph) stream)
  76   (print-unreadable-object (glyph stream :type t :identity nil)
  77     ;; FIXME: Is this really going to be Unicode?
  78     (format stream "~S U+~4,'0X"
  79             (postscript-name glyph)
  80             (code-point glyph))))
  81
  82 \f
  83 ;;; Glyph-specific values determined from data in the font-loader
  84
  85 (defgeneric left-side-bearing (object)
  86   (:method ((glyph glyph))
  87     (bounded-aref (left-side-bearings (font-loader glyph))
  88                   (font-index glyph))))
  89
  90 (defmethod (setf left-side-bearing) (new-value glyph)
  91   (setf (bounded-aref (left-side-bearings (font-loader glyph))
  92                       (font-index glyph))
  93         new-value))
  94
  95 ;;; Kerning
  96
  97 (defgeneric kerning-offset (left right loader))
  98
  99 (defmethod kerning-offset ((left-glyph glyph) (right-glyph glyph)
 100                            (font-loader font-loader))
 101   (let ((kerning-table-key (logior (ash (font-index left-glyph) 16)
 102                                    (font-index right-glyph))))
 103     (gethash kerning-table-key (kerning-table font-loader) 0)))
 104
 105 (defmethod kerning-offset ((left character) (right character)
 106                            (font-loader font-loader))
 107   (kerning-offset (find-glyph left font-loader)
 108                   (find-glyph right font-loader)
 109                   font-loader))
 110
 111 (defmethod kerning-offset ((left null) right font-loader)
 112   (declare (ignore left right font-loader))
 113   0)
 114
 115 (defmethod kerning-offset (left (right null) font-loader)
 116   (declare (ignore left right font-loader))
 117   0)
 118
 119 (defgeneric advance-width (object)
 120   (:method ((glyph glyph))
 121     (bounded-aref (advance-widths (font-loader glyph))
 122                   (font-index glyph))))
 123
 124 (defmethod (setf advance-width) (new-value (glyph glyph))
 125   (setf (bounded-aref (advance-widths (font-loader glyph))
 126                       (font-index glyph))
 127         new-value))
 128
 129 (defgeneric kerned-advance-width (object next)
 130   (:method ((object glyph) next)
 131     (+ (advance-width object)
 132        (kerning-offset object next (font-loader object)))))
 133
 134 (defgeneric location (object)
 135   (:method ((glyph glyph))
 136     (with-slots (font-index font-loader)
 137         glyph
 138       (+ (table-position "glyf" font-loader)
 139          (glyph-location font-index font-loader)))))
 140
 141 (defgeneric data-size (object)
 142   (:method ((glyph glyph))
 143     (with-slots (font-index font-loader)
 144         glyph
 145       (- (glyph-location (1+ font-index) font-loader)
 146          (glyph-location font-index font-loader)))))
 147
 148 \f
 149 ;;; Initializing delayed data
 150
 151 (defmethod initialize-bounding-box ((glyph glyph))
 152   (if (zerop (data-size glyph))
 153       (setf (bounding-box glyph) (empty-bounding-box))
 154       (let ((stream (input-stream (font-loader glyph))))
 155         ;; skip contour-count
 156         (file-position stream (+ (location glyph) 2))
 157         (setf (bounding-box glyph)
 158               (vector (read-fword stream)
 159                       (read-fword stream)
 160                       (read-fword stream)
 161                       (read-fword stream))))))
 162
 163 (defmethod initialize-contours ((glyph glyph))
 164   (if (zerop (data-size glyph))
 165       (setf (contours glyph) (empty-contours))
 166       (let ((stream (input-stream (font-loader glyph))))
 167         (file-position stream (location glyph))
 168         (let ((contour-count (read-int16 stream)))
 169           ;; skip glyph bounding box, 4 FWords
 170           (advance-file-position stream 8)
 171           (if (= contour-count -1)
 172               (setf (contours glyph)
 173                     (read-compound-contours (font-loader glyph)))
 174               (setf (contours glyph)
 175                     (read-simple-contours contour-count stream)))))))
 176
 177 (defmethod bounding-box :before ((glyph glyph))
 178   (unless (slot-boundp glyph 'bounding-box)
 179     (initialize-bounding-box glyph)))
 180
 181 (defmethod contours :before ((glyph glyph))
 182   (unless (slot-boundp glyph 'contours)
 183     (initialize-contours glyph)))
 184
 185 (defgeneric contour-count (object)
 186   (:method (object)
 187     (length (contours object))))
 188
 189 (defgeneric contour (object idex)
 190   (:method (object index)
 191     (aref (contours object) index)))
 192
 193 (defmacro do-contours ((contour object &optional result) &body body)
 194   (let ((i (gensym))
 195         (obj (gensym)))
 196     `(let ((,obj ,object))
 197        (dotimes (,i (contour-count ,obj) ,result)
 198          (let ((,contour (contour ,obj ,i)))
 199            ,@body)))))
 200
 201 (defgeneric right-side-bearing (object)
 202   (:method ((glyph glyph))
 203     (- (advance-width glyph)
 204        (- (+ (left-side-bearing glyph) (xmax glyph))
 205           (xmin glyph)))))
 206
 207 \f
 208 ;;; Producing a bounding box for a sequence of characters
 209
 210 (defgeneric string-bounding-box (string loader &key kerning))
 211
 212 (defmethod string-bounding-box (string (font-loader font-loader)
 213                                 &key (kerning t))
 214   (cond ((zerop (length string))
 215          (empty-bounding-box))
 216         ((= 1 (length string))
 217          (copy-seq (bounding-box (find-glyph (char string 0) font-loader))))
 218         (t
 219          (let ((origin 0)
 220                (left (find-glyph (char string 0) font-loader))
 221                (xmin most-positive-fixnum) (ymin most-positive-fixnum)
 222                (xmax most-negative-fixnum) (ymax most-negative-fixnum))
 223            (flet ((update-bounds (glyph)
 224                     (setf xmin (min (+ (xmin glyph) origin) xmin)
 225                           xmax (max (+ (xmax glyph) origin) xmax)
 226                           ymin (min (ymin glyph) ymin)
 227                           ymax (max (ymax glyph) ymax))))
 228              (update-bounds left)
 229              (loop for i from 1 below (length string)
 230                    for glyph = (find-glyph (char string i) font-loader)
 231                    do
 232                    (incf origin (advance-width left))
 233                    (when kerning
 234                      (incf origin (kerning-offset left glyph font-loader)))
 235                    (setf left glyph)
 236                    (update-bounds glyph)))
 237            (vector xmin ymin xmax ymax)))))
 238
 239 \f
 240 ;;; Producing glyphs from loaders
 241
 242 (defgeneric glyph-exists-p (character font-loader)
 243   (:method ((character glyph) font-loader)
 244     (let ((index (font-index character)))
 245       (not (zerop index))))
 246   (:method (character font-loader)
 247     (glyph-exists-p (find-glyph character font-loader) font-loader)))
 248
 249 (defgeneric find-glyph (character font-loader)
 250   (:documentation "Find the glyph object for CHARACTER in FONT-LOADER
 251 and return it. If CHARACTER is an integer, treat it as a Unicode code
 252 point. If CHARACTER is a Lisp character, treat its char-code as a
 253 Unicode code point.")
 254   (:method ((character integer) (font-loader font-loader))
 255     (index-glyph (code-point-font-index character font-loader) font-loader))
 256   (:method ((character character) (font-loader font-loader))
 257     (find-glyph (char-code character) font-loader)))
 258
 259 (defgeneric index-glyph (index font-loader)
 260   (:documentation "Return the GLYPH object located at glyph index
 261 INDEX in FONT-LOADER, or NIL if no glyph is defined for that
 262 index. Despite the name, NOT the inverse of GLYPH-INDEX.")
 263   (:method (index font-loader)
 264     (let* ((cache (glyph-cache font-loader))
 265            (glyph (aref cache index)))
 266       (if glyph
 267           glyph
 268           (setf (aref cache index)
 269                 (make-instance 'glyph
 270                                :font-index index
 271                                :font-loader font-loader))))))
 272
 273 \f
 274 ;;; Misc
 275
 276 (defmethod postscript-name ((glyph glyph))
 277   (let* ((names (postscript-glyph-names (font-loader glyph)))
 278          (index (font-index glyph))
 279          (name (aref names index)))
 280     (cond (name)
 281           ((slot-boundp glyph 'code-point)
 282            (setf (aref names index)
 283                  (format nil "uni~4,'0X" (code-point glyph))))
 284           (t "unknown"))))