glyf.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 ;;; Loading data from the 'glyf' table.
  28 ;;;
  29 ;;; $Id: glyf.lisp,v 1.13 2006/03/23 22:22:01 xach Exp $
  30
  31 (in-package #:zpb-ttf)
  32
  33 (defclass control-point ()
  34   ((x :initarg :x :accessor x)
  35    (y :initarg :y :accessor y)
  36    (on-curve-p :initarg :on-curve-p :reader on-curve-p)))
  37
  38 (defun make-control-point (x y on-curve-p)
  39   (make-instance 'control-point
  40                  :x x
  41                  :y y
  42                  :on-curve-p on-curve-p))
  43
  44 (defmethod print-object ((control-point control-point) stream)
  45   (print-unreadable-object (control-point stream :type t)
  46     (format stream "~D,~D~:[~;*~]"
  47             (x control-point) (y control-point) (on-curve-p control-point))))
  48
  49 (defmacro do-contour-segments* ((p1 p2) contour &body body)
  50   (let ((length (gensym))
  51         (i (gensym))
  52         (stack (gensym))
  53         (next (gensym))
  54         (next-point (gensym "NEXT-POINT"))
  55         (midpoint (gensym "MIDPOINT"))
  56         (contour* (gensym))
  57         (loop (gensym "LOOP"))
  58         (body-tag (gensym "BODY"))
  59         (done-tag (gensym "DONE"))
  60         (mid p1)
  61         (end p2))
  62     `(let* ((,i 1)
  63             (,contour* ,contour)
  64             (,length (length ,contour*))
  65             ,stack ,next ,mid ,end)
  66        (unless (zerop ,length)
  67          (unless (on-curve-p (aref ,contour* 0))
  68            (setf ,stack (aref ,contour* 0)))
  69          (flet ((,next-point ()
  70                   (when (< ,i ,length)
  71                     (prog1 (aref ,contour* ,i) (incf ,i))))
  72                 (,midpoint (p0 p1)
  73                   (make-control-point (/ (+ (x p0) (x p1)) 2)
  74                                       (/ (+ (y p0) (y p1)) 2)
  75                                       t)))
  76            (tagbody
  77               ,loop
  78               (setf ,mid nil
  79                     ,next (,next-point))
  80               (unless ,next
  81                 (setf ,mid ,stack
  82                       ,end (aref ,contour* 0))
  83                 (cond
  84                   ((on-curve-p ,end)
  85                    (go ,body-tag))
  86                   (,stack
  87                    (setf ,mid ,stack
  88                          ,end (,midpoint ,stack ,end))
  89                    (go ,body-tag))
  90                   (t (go ,done-tag))))
  91               (if (on-curve-p ,next)
  92                   (setf ,end ,next
  93                         ,mid ,stack
  94                         ,stack nil)
  95                   (cond (,stack
  96                          (setf ,mid ,stack
  97                                ,end (,midpoint ,stack ,next)
  98                                ,stack ,next))
  99                         (t
 100                          (setf ,stack ,next)
 101                          (go ,loop))))
 102               ,body-tag
 103               ,@body
 104               (when ,next
 105                 (go ,loop))
 106               ,done-tag))))))
 107
 108 (defun start-of-contour (contour)
 109   "If first point of a contour is on the curve, return it, otherwise
 110 find and return previous (possibly implicit) point on the curve."
 111   (let ((first (aref contour 0)))
 112    (if (on-curve-p first)
 113        first
 114        (let ((last (aref contour (1- (length contour)))))
 115          (if (on-curve-p last)
 116              last
 117              ;; both are off curve, return the implicit on-curve point
 118              (make-control-point (/ (+ (x first) (x last)) 2)
 119                                  (/ (+ (y first) (y last)) 2)
 120                                  t))))))
 121
 122 (defmacro do-contour-segments ((p0 p1 p2) contour &body body)
 123     "A contour is made up of segments. A segment may be a straight line
 124 or a curve. For each segment, bind the P0 and P2 variables to the
 125 start and end points of the segment. If the segment is a curve, set P1
 126 to the control point of the curve, otherwise set P1 to NIL."
 127     ;; This macro started out life as a function and was converted.
 128     (let ((start p0)
 129           (contour* (gensym "CONTOUR")))
 130       `(let ((,contour* ,contour))
 131          (when (plusp (length ,contour*))
 132            (let ((,start (start-of-contour ,contour*)))
 133              (do-contour-segments* (,p1 ,p2)
 134                  ,contour*
 135                (progn ,@body)
 136                (setf ,start ,p2)))))))
 137
 138 (defun explicit-contour-points (contour)
 139   (let ((new-contour (make-array (length contour)
 140                                  :adjustable t
 141                                  :fill-pointer 0)))
 142     (when (and (plusp (length contour))
 143                (on-curve-p (aref contour 0)))
 144       (vector-push-extend (aref contour 0) new-contour))
 145     (do-contour-segments* (p1 p2)
 146         contour
 147       (when p1
 148         (vector-push-extend p1 new-contour))
 149       (unless (eql p2 (aref contour 0))
 150         (vector-push-extend p2 new-contour)))
 151     new-contour))
 152
 153 \f
 154 ;;; Locating a glyph's contours and bounding box in the font loader's
 155 ;;; stream, and loading them
 156
 157 (defparameter *empty-contours*
 158   (make-array 0 :element-type '(signed-byte 16)))
 159
 160 (defparameter *empty-bounding-box*
 161   (make-array 4
 162               :initial-element 0
 163               :element-type '(signed-byte 16)))
 164
 165 (defun empty-bounding-box ()
 166   (copy-seq *empty-bounding-box*))
 167
 168 (defun empty-contours ()
 169   (copy-seq *empty-contours*))
 170
 171 (defun dump-compound-flags (flags)
 172   (format t "XXX flags=~16,'0B~%" flags)
 173   (let ((meanings '((0 . ARG_1_AND_2_ARE_WORDS)
 174                        (1 . ARGS_ARE_XY_VALUES)
 175                        (2 . ROUND_XY_TO_GRID)
 176                        (3 . WE_HAVE_A_SCALE)
 177                        (4 . OBSOLETE)
 178                        (5 . MORE_COMPONENTS)
 179                        (6 . WE_HAVE_AN_X_AND_Y_SCALE)
 180                        (7 . WE_HAVE_A_TWO_BY_TWO)
 181                        (8 . WE_HAVE_INSTRUCTIONS)
 182                        (9 . USE_MY_METRICS)
 183                        (10 . OVERLAP_COMPOUND))))
 184        (loop for ((bit . meaning)) on meanings
 185              do (when (logbitp bit flags)
 186                   (format t "...~A~%" meaning)))))
 187
 188 (defun transform-option-count (flags)
 189   (let ((scale-p 3)
 190         (xy-scale-p 6)
 191         (2*2-scale-p 7))
 192     (cond ((logbitp scale-p flags) 1)
 193           ((logbitp xy-scale-p flags) 2)
 194           ((logbitp 2*2-scale-p flags) 4)
 195           (t 0))))
 196
 197 (defun make-transformer (a b c d e f)
 198   "Given the elements of the transformation matrix specified by A, B,
 199 C, D, E, and F, return a function of two arguments that returns the
 200 arguments transformed as multiple values.
 201 Ref: http://developer.apple.com/fonts/TTRefMan/RM06/Chap6glyf.html"
 202   (let ((m (max (abs a) (abs b)))
 203         (n (max (abs c) (abs d))))
 204     (when (<= (abs (- (abs a) (abs b))) 33/65536)
 205       (setf m (* m 2)))
 206     (when (<= (abs (- (abs c) (abs d))) 33/65536)
 207       (setf n (* n 2)))
 208     (lambda (x y)
 209       (values (* m (+ (* (/ a m) x)
 210                       (* (/ c m) y)
 211                       e))
 212               (* n (+ (* (/ b n) x)
 213                       (* (/ d n) y)
 214                       f))))))
 215
 216 (defun transform-contours (fn contours)
 217   "Call FN with the X and Y coordinates of each point of each contour
 218 in the vector CONTOURS. FN should return two values, which are used to
 219 update the X and Y values of each point."
 220   (loop for contour across contours do
 221         (loop for p across contour do
 222               (setf (values (x p) (y p))
 223                     (funcall fn (x p) (y p))))))
 224
 225 (defun merge-contours (contours-list)
 226   (let* ((total-contours (loop for contours in contours-list
 227                                summing (length contours)))
 228          (merged (make-array total-contours))
 229          (i 0))
 230     (dolist (contours contours-list merged)
 231       (loop for contour across contours do
 232             (setf (aref merged i) contour)
 233             (incf i)))))
 234
 235 (defvar *compound-contour-loop-check*)
 236
 237 (defun read-compound-contours (loader)
 238   (let ((contours-list '())
 239         (stream (input-stream loader)))
 240     (loop
 241      (let ((flags (read-uint16 stream))
 242            (font-index (read-uint16 stream)))
 243        (let ((position (file-position stream))
 244              (contours (read-contours-at-index font-index loader)))
 245          (push contours contours-list)
 246          (file-position stream position)
 247          (let ((args-words-p (logbitp 0 flags))
 248                (args-xy-values-p (logbitp 1 flags))
 249                (more-components-p (logbitp 5 flags))
 250                arg1 arg2)
 251            (cond ((and args-words-p args-xy-values-p)
 252                   (setf arg1 (read-int16 stream)
 253                         arg2 (read-int16 stream)))
 254                  (args-words-p
 255                   (setf arg1 (read-uint16 stream)
 256                         arg2 (read-uint16 stream))
 257                   (error "Compound glyphs relative to indexes not yet supported"))
 258                  (args-xy-values-p
 259                   (setf arg1 (read-int8 stream)
 260                         arg2 (read-int8 stream)))
 261                  (t
 262                   (setf arg1 (read-uint8 stream)
 263                         arg2 (read-uint8 stream))
 264                   (error "Compound glyphs relative to indexes not yet supported")))
 265            ;; Transform according to the transformation matrix
 266            (let ((a 1.0) (b 0.0) (c 0.0) (d 1.0)
 267                  (e arg1) (f arg2))
 268              (ecase (transform-option-count flags)
 269                (0)
 270                (1
 271                 (setf a (setf d (read-fixed2.14 stream))))
 272                (2
 273                 (setf a (read-fixed2.14 stream)
 274                       d (read-fixed2.14 stream)))
 275                (4
 276                 (setf a (read-fixed2.14 stream)
 277                       b (read-fixed2.14 stream)
 278                       c (read-fixed2.14 stream)
 279                       d (read-fixed2.14 stream))))
 280              (let ((transform-fn (make-transformer a b c d e f)))
 281                (transform-contours transform-fn contours)))
 282            (unless more-components-p
 283              (return (merge-contours contours-list)))))))))
 284
 285 (defun read-points-vector (stream flags count axis)
 286   (let ((points (make-array count :fill-pointer 0))
 287         (short-index (if (eql axis :x) 1 2))
 288         (same-index (if (eql axis :x) 4 5)))
 289     (flet ((save-point (point)
 290              (vector-push point points)))
 291       (loop for flag across flags
 292             for short-p = (logbitp short-index flag)
 293             for same-p = (logbitp same-index flag)
 294             do (cond (short-p
 295                       (let ((new-point (read-uint8 stream)))
 296                         (save-point (if same-p new-point (- new-point)))))
 297                      (t
 298                       (if same-p
 299                           (save-point 0)
 300                           (save-point (read-int16 stream)))))))
 301     points))
 302
 303 (defun read-simple-contours (contour-count stream)
 304   "With the stream positioned immediately after the glyph bounding
 305 box, read the contours data from STREAM and return it as a vector."
 306   (let ((contour-endpoint-indexes (make-array contour-count)))
 307     (loop for i below contour-count
 308           for endpoint-index = (read-uint16 stream)
 309           do (setf (svref contour-endpoint-indexes i) endpoint-index))
 310     ;; instructions
 311     (let ((n-points (1+ (svref contour-endpoint-indexes
 312                                (1- contour-count))))
 313           (instruction-length (read-uint16 stream)))
 314       (loop for i below instruction-length
 315             do (read-byte stream))
 316       ;; read the flags
 317       (let ((flags (make-array n-points)))
 318         (loop with i = 0
 319               while (< i n-points) do
 320               (let ((flag-byte (read-uint8 stream)))
 321                 (setf (svref flags i) flag-byte)
 322                 (incf i)
 323                 (when (logbitp 3 flag-byte)
 324                   (let ((n-repeats (read-uint8 stream)))
 325                     (loop repeat n-repeats do
 326                           (setf (svref flags i) flag-byte)
 327                           (incf i))))))
 328         (let ((x-points (read-points-vector stream flags n-points :x ))
 329               (y-points (read-points-vector stream flags n-points :y))
 330               (control-points (make-array n-points :fill-pointer 0))
 331               (contours (make-array contour-count)))
 332           (loop for x-point across x-points
 333                 for y-point across y-points
 334                 for flag across flags
 335                 for x = x-point then (+ x x-point)
 336                 for y = y-point then (+ y y-point)
 337                 do
 338                 (vector-push-extend (make-control-point x y
 339                                                         (logbitp 0 flag))
 340                                     control-points))
 341           (loop for start = 0 then (1+ end)
 342                 for end across contour-endpoint-indexes
 343                 for i from 0
 344                 do (setf (svref contours i)
 345                          (subseq control-points start (1+ end))))
 346           contours)))))
 347
 348 (defmacro with-compound-contour-loop (() &body body)
 349   `(let ((*compound-contour-loop-check*
 350            (if (boundp '*compound-contour-loop-check*)
 351                *compound-contour-loop-check*
 352                (make-hash-table))))
 353      ,@body))
 354
 355 (defun read-contours-at-index (index loader)
 356   "Read the contours at glyph index INDEX, discarding bounding box
 357 information."
 358   (let ((stream (input-stream loader)))
 359     (file-position stream (+ (table-position "glyf" loader)
 360                              (glyph-location index loader)))
 361     (let ((contour-count (read-int16 stream))
 362           (xmin (read-int16 stream))
 363           (ymin (read-int16 stream))
 364           (xmax (read-int16 stream))
 365           (ymax (read-int16 stream)))
 366       (declare (ignore xmin ymin xmax ymax))
 367       (if (= contour-count -1)
 368           (with-compound-contour-loop ()
 369             ;; some fonts have compound contours that contain
 370             ;; themselves, so we try to detect that.
 371             (when (gethash index *compound-contour-loop-check*)
 372               (return-from read-contours-at-index
 373                 (gethash index *compound-contour-loop-check*)))
 374             ;; store a value for when we detect a loop
 375             (setf (gethash index *compound-contour-loop-check*)
 376                   #())
 377             ;; It is reasonable for a particular contour to be
 378             ;; included multiple times within the tree of compounds,
 379             ;; though, so for that case we save the value and reuse
 380             ;; it.
 381             (setf (gethash index *compound-contour-loop-check*)
 382                   (read-compound-contours loader)))
 383           (read-simple-contours contour-count stream)))))