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         (mid p1)
  60         (end p2))
  61     `(let* ((,i 1)
  62             (,contour* ,contour)
  63             (,length (length ,contour*))
  64             ,stack ,next ,mid ,end)
  65        (unless (zerop ,length)
  66          (flet ((,next-point ()
  67                   (when (< ,i ,length)
  68                     (prog1 (aref ,contour* ,i) (incf ,i))))
  69                 (,midpoint (p0 p1)
  70                   (make-control-point (/ (+ (x p0) (x p1)) 2)
  71                                       (/ (+ (y p0) (y p1)) 2)
  72                                       t)))
  73            (tagbody
  74               ,loop
  75               (setf ,mid nil
  76                     ,next (,next-point))
  77               (unless ,next
  78                 (setf ,mid ,stack
  79                       ,end (aref ,contour* 0))
  80                 (go ,body-tag))
  81               (if (on-curve-p ,next)
  82                   (setf ,end ,next
  83                         ,mid ,stack
  84                         ,stack nil)
  85                   (cond (,stack
  86                          (setf ,mid ,stack
  87                                ,end (,midpoint ,stack ,next)
  88                                ,stack ,next))
  89                         (t
  90                          (setf ,stack ,next)
  91                          (go ,loop))))
  92               ,body-tag
  93               ,@body
  94               (when ,next
  95                 (go ,loop))))))))
  96
  97 (defmacro do-contour-segments ((p0 p1 p2) contour &body body)
  98     "A contour is made up of segments. A segment may be a straight line
  99 or a curve. For each segment, bind the P0 and P2 variables to the
 100 start and end points of the segment. If the segment is a curve, set P1
 101 to the control point of the curve, otherwise set P1 to NIL."
 102     ;; This macro started out life as a function and was converted.
 103     (let ((start p0)
 104           (contour* (gensym "CONTOUR")))
 105       `(let ((,contour* ,contour))
 106          (when (plusp (length ,contour*))
 107            (let ((,start (aref ,contour* 0)))
 108              (do-contour-segments* (,p1 ,p2)
 109                  ,contour*
 110                (progn ,@body)
 111                (setf ,start ,p2)))))))
 112
 113 (defun explicit-contour-points (contour)
 114   (let ((new-contour (make-array (length contour)
 115                                  :adjustable t
 116                                  :fill-pointer 0)))
 117     (when (plusp (length contour))
 118       (vector-push-extend (aref contour 0) new-contour))
 119     (do-contour-segments* (p1 p2)
 120         contour
 121       (when p1
 122         (vector-push-extend p1 new-contour))
 123       (vector-push-extend p2 new-contour))
 124     new-contour))
 125
 126 \f
 127 ;;; Locating a glyph's contours and bounding box in the font loader's
 128 ;;; stream, and loading them
 129
 130 (defparameter *empty-contours*
 131   (make-array 0 :element-type '(signed-byte 16)))
 132
 133 (defparameter *empty-bounding-box*
 134   (make-array 4
 135               :initial-element 0
 136               :element-type '(signed-byte 16)))
 137
 138 (defun empty-bounding-box ()
 139   (copy-seq *empty-bounding-box*))
 140
 141 (defun empty-contours ()
 142   (copy-seq *empty-contours*))
 143
 144 (defun dump-compound-flags (flags)
 145   (format t "XXX flags=~16,'0B~%" flags)
 146   (let ((meanings '((0 . ARG_1_AND_2_ARE_WORDS)
 147                        (1 . ARGS_ARE_XY_VALUES)
 148                        (2 . ROUND_XY_TO_GRID)
 149                        (3 . WE_HAVE_A_SCALE)
 150                        (4 . OBSOLETE)
 151                        (5 . MORE_COMPONENTS)
 152                        (6 . WE_HAVE_AN_X_AND_Y_SCALE)
 153                        (7 . WE_HAVE_A_TWO_BY_TWO)
 154                        (8 . WE_HAVE_INSTRUCTIONS)
 155                        (9 . USE_MY_METRICS)
 156                        (10 . OVERLAP_COMPOUND))))
 157        (loop for ((bit . meaning)) on meanings
 158              do (when (logbitp bit flags)
 159                   (format t "...~A~%" meaning)))))
 160
 161 (defun transform-option-count (flags)
 162   (let ((scale-p 3)
 163         (xy-scale-p 6)
 164         (2*2-scale-p 7))
 165     (cond ((logbitp scale-p flags) 1)
 166           ((logbitp xy-scale-p flags) 2)
 167           ((logbitp 2*2-scale-p flags) 4)
 168           (t 0))))
 169
 170 (defun make-transformer (a b c d e f)
 171   "Given the elements of the transformation matrix specified by A, B,
 172 C, D, E, and F, return a function of two arguments that returns the
 173 arguments transformed as multiple values.
 174 Ref: http://developer.apple.com/fonts/TTRefMan/RM06/Chap6glyf.html"
 175   (let ((m (max (abs a) (abs b)))
 176         (n (max (abs c) (abs d))))
 177     (when (<= (abs (- (abs a) (abs b))) 33/65536)
 178       (setf m (* m 2)))
 179     (when (<= (abs (- (abs c) (abs d))) 33/65536)
 180       (setf n (* n 2)))
 181     (lambda (x y)
 182       (values (* m (+ (* (/ a m) x)
 183                       (* (/ c m) y)
 184                       e))
 185               (* n (+ (* (/ b n) x)
 186                       (* (/ d n) y)
 187                       f))))))
 188
 189 (defun transform-contours (fn contours)
 190   "Call FN with the X and Y coordinates of each point of each contour
 191 in the vector CONTOURS. FN should return two values, which are used to
 192 update the X and Y values of each point."
 193   (loop for contour across contours do
 194         (loop for p across contour do
 195               (setf (values (x p) (y p))
 196                     (funcall fn (x p) (y p))))))
 197
 198 (defun merge-contours (contours-list)
 199   (let* ((total-contours (loop for contours in contours-list
 200                                summing (length contours)))
 201          (merged (make-array total-contours))
 202          (i 0))
 203     (dolist (contours contours-list merged)
 204       (loop for contour across contours do
 205             (setf (aref merged i) contour)
 206             (incf i)))))
 207
 208 (defun read-compound-contours (loader)
 209   (let ((contours-list '())
 210         (stream (input-stream loader)))
 211     (loop
 212      (let ((flags (read-uint16 stream))
 213            (font-index (read-uint16 stream)))
 214        (let ((position (file-position stream))
 215              (contours (read-contours-at-index font-index loader)))
 216          (push contours contours-list)
 217          (file-position stream position)
 218          (let ((args-words-p (logbitp 0 flags))
 219                (args-xy-values-p (logbitp 1 flags))
 220                (more-components-p (logbitp 5 flags))
 221                arg1 arg2)
 222            (cond ((and args-words-p args-xy-values-p)
 223                   (setf arg1 (read-int16 stream)
 224                         arg2 (read-int16 stream)))
 225                  (args-words-p
 226                   (setf arg1 (read-uint16 stream)
 227                         arg2 (read-uint16 stream))
 228                   (error "Compound glyphs relative to indexes not yet supported"))
 229                  (args-xy-values-p
 230                   (setf arg1 (read-int8 stream)
 231                         arg2 (read-int8 stream)))
 232                  (t
 233                   (setf arg1 (read-uint8 stream)
 234                         arg2 (read-uint8 stream))
 235                   (error "Compound glyphs relative to indexes not yet supported")))
 236            ;; Transform according to the transformation matrix
 237            (let ((a 1.0) (b 0.0) (c 0.0) (d 1.0)
 238                  (e arg1) (f arg2))
 239              (ecase (transform-option-count flags)
 240                (0)
 241                (1
 242                 (setf a (setf d (read-fixed2.14 stream))))
 243                (2
 244                 (setf a (read-fixed2.14 stream)
 245                       d (read-fixed2.14 stream)))
 246                (4
 247                 (setf a (read-fixed2.14 stream)
 248                       b (read-fixed2.14 stream)
 249                       c (read-fixed2.14 stream)
 250                       d (read-fixed2.14 stream))))
 251              (let ((transform-fn (make-transformer a b c d e f)))
 252                (transform-contours transform-fn contours)))
 253            (unless more-components-p
 254              (return (merge-contours contours-list)))))))))
 255
 256 (defun read-points-vector (stream flags count axis)
 257   (let ((points (make-array count :fill-pointer 0))
 258         (short-index (if (eql axis :x) 1 2))
 259         (same-index (if (eql axis :x) 4 5)))
 260     (flet ((save-point (point)
 261              (vector-push point points)))
 262       (loop for flag across flags
 263             for short-p = (logbitp short-index flag)
 264             for same-p = (logbitp same-index flag)
 265             do (cond (short-p
 266                       (let ((new-point (read-uint8 stream)))
 267                         (save-point (if same-p new-point (- new-point)))))
 268                      (t
 269                       (if same-p
 270                           (save-point 0)
 271                           (save-point (read-int16 stream)))))))
 272     points))
 273
 274 (defun read-simple-contours (contour-count stream)
 275   "With the stream positioned immediately after the glyph bounding
 276 box, read the contours data from STREAM and return it as a vector."
 277   (let ((contour-endpoint-indexes (make-array contour-count)))
 278     (loop for i below contour-count
 279           for endpoint-index = (read-uint16 stream)
 280           do (setf (svref contour-endpoint-indexes i) endpoint-index))
 281     ;; instructions
 282     (let ((n-points (1+ (svref contour-endpoint-indexes
 283                                (1- contour-count))))
 284           (instruction-length (read-uint16 stream)))
 285       (loop for i below instruction-length
 286             do (read-byte stream))
 287       ;; read the flags
 288       (let ((flags (make-array n-points)))
 289         (loop with i = 0
 290               while (< i n-points) do
 291               (let ((flag-byte (read-uint8 stream)))
 292                 (setf (svref flags i) flag-byte)
 293                 (incf i)
 294                 (when (logbitp 3 flag-byte)
 295                   (let ((n-repeats (read-uint8 stream)))
 296                     (loop repeat n-repeats do
 297                           (setf (svref flags i) flag-byte)
 298                           (incf i))))))
 299         (let ((x-points (read-points-vector stream flags n-points :x ))
 300               (y-points (read-points-vector stream flags n-points :y))
 301               (control-points (make-array n-points :fill-pointer 0))
 302               (contours (make-array contour-count)))
 303           (loop for x-point across x-points
 304                 for y-point across y-points
 305                 for flag across flags
 306                 for x = x-point then (+ x x-point)
 307                 for y = y-point then (+ y y-point)
 308                 do
 309                 (vector-push-extend (make-control-point x y
 310                                                         (logbitp 0 flag))
 311                                     control-points))
 312           (loop for start = 0 then (1+ end)
 313                 for end across contour-endpoint-indexes
 314                 for i from 0
 315                 do (setf (svref contours i)
 316                          (subseq control-points start (1+ end))))
 317           contours)))))
 318
 319 (defun read-contours-at-index (index loader)
 320   "Read the contours at glyph index INDEX, discarding bounding box
 321 information."
 322   (let ((stream (input-stream loader)))
 323     (file-position stream (+ (table-position "glyf" loader)
 324                              (glyph-location index loader)))
 325     (let ((contour-count (read-int16 stream))
 326           (xmin (read-int16 stream))
 327           (ymin (read-int16 stream))
 328           (xmax (read-int16 stream))
 329           (ymax (read-int16 stream)))
 330       (declare (ignore xmin ymin xmax ymax))
 331       (if (= contour-count -1)
 332           (read-compound-contours loader)
 333           (read-simple-contours contour-count stream)))))