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 ;;; Horizontal metrics
  86
  87 (defgeneric left-side-bearing (object)
  88   (:method ((glyph glyph))
  89     (bounded-aref (left-side-bearings (font-loader glyph))
  90                   (font-index glyph))))
  91
  92 (defmethod (setf left-side-bearing) (new-value glyph)
  93   (setf (bounded-aref (left-side-bearings (font-loader glyph))
  94                       (font-index glyph))
  95         new-value))
  96
  97 (defgeneric advance-width (object)
  98   (:method ((glyph glyph))
  99     (bounded-aref (advance-widths (font-loader glyph))
 100                   (font-index glyph))))
 101
 102 (defmethod (setf advance-width) (new-value (glyph glyph))
 103   (setf (bounded-aref (advance-widths (font-loader glyph))
 104                       (font-index glyph))
 105         new-value))
 106
 107 ;;; Vertical metrics
 108
 109 (defgeneric top-side-bearing (object)
 110   (:method ((glyph glyph))
 111     (let ((loader (font-loader glyph)))
 112       (if (vmtx-missing-p loader)
 113           (- (ascender loader) (ymax glyph))
 114           (bounded-aref (top-side-bearings (font-loader glyph))
 115                         (font-index glyph))))))
 116
 117 (defmethod (setf top-side-bearing) (new-value glyph)
 118   (setf (bounded-aref (top-side-bearings (font-loader glyph))
 119                       (font-index glyph))
 120         new-value))
 121
 122 (defgeneric advance-height (object)
 123   (:method ((glyph glyph))
 124     (bounded-aref (advance-heights (font-loader glyph))
 125                   (font-index glyph))))
 126
 127 (defmethod (setf advance-height) (new-value (glyph glyph))
 128   (setf (bounded-aref (advance-heights (font-loader glyph))
 129                       (font-index glyph))
 130         new-value))
 131
 132 ;;; Kerning
 133
 134 (defgeneric kerning-offset (left right loader))
 135
 136 (defmethod kerning-offset ((left-glyph glyph) (right-glyph glyph)
 137                            (font-loader font-loader))
 138   (let ((kerning-table-key (logior (ash (font-index left-glyph) 16)
 139                                    (font-index right-glyph))))
 140     (gethash kerning-table-key (kerning-table font-loader) 0)))
 141
 142 (defmethod kerning-offset ((left character) (right character)
 143                            (font-loader font-loader))
 144   (kerning-offset (find-glyph left font-loader)
 145                   (find-glyph right font-loader)
 146                   font-loader))
 147
 148 (defmethod kerning-offset ((left null) right font-loader)
 149   (declare (ignore left right font-loader))
 150   0)
 151
 152 (defmethod kerning-offset (left (right null) font-loader)
 153   (declare (ignore left right font-loader))
 154   0)
 155
 156 (defgeneric kerned-advance-width (object next)
 157   (:method ((object glyph) next)
 158     (+ (advance-width object)
 159        (kerning-offset object next (font-loader object)))))
 160
 161 (defgeneric location (object)
 162   (:method ((glyph glyph))
 163     (with-slots (font-index font-loader)
 164         glyph
 165       (+ (table-position "glyf" font-loader)
 166          (glyph-location font-index font-loader)))))
 167
 168 (defgeneric data-size (object)
 169   (:method ((glyph glyph))
 170     (with-slots (font-index font-loader)
 171         glyph
 172       (- (glyph-location (1+ font-index) font-loader)
 173          (glyph-location font-index font-loader)))))
 174
 175 \f
 176 ;;; Initializing delayed data
 177
 178 (defmethod initialize-bounding-box ((glyph glyph))
 179   (if (zerop (data-size glyph))
 180       (setf (bounding-box glyph) (empty-bounding-box))
 181       (let ((stream (input-stream (font-loader glyph))))
 182         ;; skip contour-count
 183         (file-position stream (+ (location glyph) 2))
 184         (setf (bounding-box glyph)
 185               (vector (read-fword stream)
 186                       (read-fword stream)
 187                       (read-fword stream)
 188                       (read-fword stream))))))
 189
 190 (defmethod initialize-contours ((glyph glyph))
 191   (if (zerop (data-size glyph))
 192       (setf (contours glyph) (empty-contours))
 193       (let ((stream (input-stream (font-loader glyph))))
 194         (file-position stream (location glyph))
 195         (let ((contour-count (read-int16 stream)))
 196           ;; skip glyph bounding box, 4 FWords
 197           (advance-file-position stream 8)
 198           (if (= contour-count -1)
 199               (setf (contours glyph)
 200                     (read-compound-contours (font-loader glyph)))
 201               (setf (contours glyph)
 202                     (read-simple-contours contour-count stream)))))))
 203
 204 (defmethod bounding-box :before ((glyph glyph))
 205   (unless (slot-boundp glyph 'bounding-box)
 206     (initialize-bounding-box glyph)))
 207
 208 (defmethod contours :before ((glyph glyph))
 209   (unless (slot-boundp glyph 'contours)
 210     (initialize-contours glyph)))
 211
 212 (defgeneric contour-count (object)
 213   (:method (object)
 214     (length (contours object))))
 215
 216 (defgeneric contour (object idex)
 217   (:method (object index)
 218     (aref (contours object) index)))
 219
 220 (defmacro do-contours ((contour object &optional result) &body body)
 221   (let ((i (gensym))
 222         (obj (gensym)))
 223     `(let ((,obj ,object))
 224        (dotimes (,i (contour-count ,obj) ,result)
 225          (let ((,contour (contour ,obj ,i)))
 226            ,@body)))))
 227
 228 (defgeneric right-side-bearing (object)
 229   (:method ((glyph glyph))
 230     (- (advance-width glyph)
 231        (- (+ (left-side-bearing glyph) (xmax glyph))
 232           (xmin glyph)))))
 233
 234 \f
 235 ;;; Producing a bounding box for a sequence of characters
 236
 237 (defgeneric string-bounding-box (string loader &key kerning))
 238
 239 (defmethod string-bounding-box (string (font-loader font-loader)
 240                                 &key (kerning t))
 241   (cond ((zerop (length string))
 242          (empty-bounding-box))
 243         ((= 1 (length string))
 244          (copy-seq (bounding-box (find-glyph (char string 0) font-loader))))
 245         (t
 246          (let ((origin 0)
 247                (left (find-glyph (char string 0) font-loader))
 248                (xmin most-positive-fixnum) (ymin most-positive-fixnum)
 249                (xmax most-negative-fixnum) (ymax most-negative-fixnum))
 250            (flet ((update-bounds (glyph)
 251                     (setf xmin (min (+ (xmin glyph) origin) xmin)
 252                           xmax (max (+ (xmax glyph) origin) xmax)
 253                           ymin (min (ymin glyph) ymin)
 254                           ymax (max (ymax glyph) ymax))))
 255              (update-bounds left)
 256              (loop for i from 1 below (length string)
 257                    for glyph = (find-glyph (char string i) font-loader)
 258                    do
 259                    (incf origin (advance-width left))
 260                    (when kerning
 261                      (incf origin (kerning-offset left glyph font-loader)))
 262                    (setf left glyph)
 263                    (update-bounds glyph)))
 264            (vector xmin ymin xmax ymax)))))
 265
 266 \f
 267 ;;; Producing glyphs from loaders
 268
 269 (defgeneric glyph-exists-p (character font-loader)
 270   (:method ((character glyph) font-loader)
 271     (let ((index (font-index character)))
 272       (not (zerop index))))
 273   (:method (character font-loader)
 274     (glyph-exists-p (find-glyph character font-loader) font-loader)))
 275
 276 (defgeneric find-glyph (character font-loader)
 277   (:documentation "Find the glyph object for CHARACTER in FONT-LOADER
 278 and return it. If CHARACTER is an integer, treat it as a Unicode code
 279 point. If CHARACTER is a Lisp character, treat its char-code as a
 280 Unicode code point.")
 281   (:method ((character integer) (font-loader font-loader))
 282     (index-glyph (code-point-font-index character font-loader) font-loader))
 283   (:method ((character character) (font-loader font-loader))
 284     (find-glyph (char-code character) font-loader)))
 285
 286 (defgeneric index-glyph (index font-loader)
 287   (:documentation "Return the GLYPH object located at glyph index
 288 INDEX in FONT-LOADER, or NIL if no glyph is defined for that
 289 index. Despite the name, NOT the inverse of GLYPH-INDEX.")
 290   (:method (index font-loader)
 291     (let* ((cache (glyph-cache font-loader))
 292            (glyph (aref cache index)))
 293       (if glyph
 294           glyph
 295           (setf (aref cache index)
 296                 (make-instance 'glyph
 297                                :font-index index
 298                                :font-loader font-loader))))))
 299
 300 \f
 301 ;;; Misc
 302
 303 (defmethod postscript-name ((glyph glyph))
 304   (let* ((names (postscript-glyph-names (font-loader glyph)))
 305          (index (font-index glyph))
 306          (name (aref names index)))
 307     (cond (name)
 308           ((slot-boundp glyph 'code-point)
 309            (setf (aref names index)
 310                  (format nil "uni~4,'0X" (code-point glyph))))
 311           (t "unknown"))))