kern.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 ;;; "kern" table functions
  28 ;;;
  29 ;;;   https://docs.microsoft.com/en-us/typography/opentype/spec/kern
  30 ;;;   http://developer.apple.com/fonts/TTRefMan/RM06/Chap6kern.html
  31 ;;;
  32 ;;; $Id: kern.lisp,v 1.8 2006/03/28 14:38:37 xach Exp $
  33
  34 (in-package #:zpb-ttf)
  35
  36 (defun load-kerning-format-0 (table stream)
  37   "Return a hash table keyed on a UINT32 key that represents the glyph
  38 index in the left and right halves with a value of the kerning
  39 distance between the pair."
  40   (let ((pair-count (read-uint16 stream))
  41         (search-range (read-uint16 stream))
  42         (entry-selector (read-uint16 stream))
  43         (range-shift (read-uint16 stream))
  44         (bytes-read 8))
  45     (declare (ignore search-range entry-selector range-shift))
  46     (dotimes (i pair-count)
  47       (let ((key (read-uint32 stream))
  48             (value (read-int16 stream)))
  49         ;; apple specifies a terminating entry, ignore it
  50         (unless (and (= key #xffffffff) (= value 0))
  51           (setf (gethash key table) value))
  52         (incf bytes-read 6)))
  53     bytes-read))
  54
  55 (defun parse-offset-table (buffer start)
  56   (let ((first-glyph (aref buffer start))
  57         (glyph-count (aref buffer (1+ start)))
  58         (offsets (make-hash-table)))
  59     (loop for i from (+ start 2)
  60           for g from first-glyph
  61           repeat glyph-count
  62           collect (setf (gethash g offsets) (aref buffer i)))
  63     offsets))
  64
  65 (defun load-kerning-format-2 (table stream size)
  66   "Return a hash table keyed on a UINT32 key that represents the glyph
  67 index in the left and right halves with a value of the kerning
  68 distance between the pair."
  69   (let* ((buffer (coerce (loop repeat (/ size 2)
  70                                collect (read-uint16 stream))
  71                          '(simple-array (unsigned-byte) 1)))
  72          (row-width (aref buffer 0))
  73          (left-offset-table (aref buffer 1))
  74          (right-offset-table (aref buffer 2))
  75          (array-offset (aref buffer 3))
  76          (left (parse-offset-table buffer (- (/ left-offset-table 2) 4)))
  77          (right (parse-offset-table buffer (- (/ right-offset-table 2) 4))))
  78     (declare (ignorable row-width array-offset))
  79     (flet ((s16 (x)
  80              (if (logbitp 15 x)
  81                  (1- (- (logandc2 #xFFFF x)))
  82                  x)))
  83       (maphash (lambda (lk lv)
  84                  (maphash (lambda (rk rv)
  85                             (let ((key (logior (ash lk 16) rk))
  86                                   (value (s16 (aref buffer
  87                                                     (- (/ (+ lv rv) 2) 4)))))
  88                               (unless (zerop value)
  89                                 (setf (gethash key table) value))))
  90                           right))
  91                left))
  92     size))
  93
  94 (defmethod load-kerning-subtable ((font-loader font-loader) format size)
  95   (when (/= format 0 1 2)
  96     (error 'unsupported-format
  97            :description "kerning subtable"
  98            :size 1
  99            :expected-values (list 0 1 2)
 100            :actual-value format))
 101   (case format
 102     (0
 103      (load-kerning-format-0 (kerning-table font-loader)
 104                             (input-stream font-loader)))
 105     (1
 106      ;; state table for contextual kerning, ignored for now
 107      (advance-file-position (input-stream font-loader) (- size 8))
 108      (- size 8))
 109     (2
 110      (load-kerning-format-2 (kerning-table font-loader)
 111                             (input-stream font-loader)
 112                             size))))
 113
 114 (defmethod load-kern-info ((font-loader font-loader))
 115   (when (table-exists-p "kern" font-loader)
 116     (seek-to-table "kern" font-loader)
 117     (let* ((stream (input-stream font-loader))
 118            (maybe-version (read-uint16 stream))
 119            (maybe-table-count (read-uint16 stream))
 120            (version 0)
 121            (table-count 0)
 122            (apple-p nil))
 123
 124       ;; These shenanegins are because Apple documents one style of
 125       ;; kern table and Microsoft documents another. This code
 126       ;; tries to support both.
 127       ;; See:
 128       ;;  https://developer.apple.com/fonts/TrueType-Reference-Manual/RM06/Chap6kern.html
 129       ;;  https://learn.microsoft.com/en-us/typography/opentype/spec/kern
 130       (if (zerop maybe-version)
 131           (setf version maybe-version
 132                 table-count maybe-table-count)
 133           (setf version (logand (ash maybe-version 16) maybe-table-count)
 134                 table-count (read-uint32 stream)
 135                 apple-p t))
 136       (check-version "\"kern\" table" version 0)
 137       (dotimes (i table-count)
 138         (let ((version (read-uint16 stream))
 139               (length (read-uint16 stream))
 140               (coverage-flags (read-uint8 stream))
 141               (format (read-uint8 stream)))
 142           (declare (ignorable version))
 143           (case coverage-flags
 144             ;; only read horizontal kerning, since storing others in
 145             ;; same array would be confusing and vertical layouts
 146             ;; don't seem to be supported currently
 147             (0
 148              (when apple-p
 149                (read-uint16 stream))    ; read and discard tuple-index
 150
 151              (let ((bytes-read (+ (load-kerning-subtable font-loader format
 152                                                          length)
 153                                   (if apple-p 8 6))))
 154                (advance-file-position stream (- length bytes-read))))
 155             ;; ignore other known types of kerning
 156             ((#x8000  ;; vertical
 157               #x4000  ;; cross stream
 158               #x2000) ;; variation
 159              (advance-file-position stream (- length 6)))
 160             ;; otherwise error
 161             (otherwise
 162              (error 'unsupported-format
 163                     :description "kerning subtable coverage"
 164                     :size 2
 165                     :expected-values (list 0 #x2000 #x4000 #x8000)
 166                     :actual-value coverage-flags))))))))
 167
 168 (defmethod all-kerning-pairs ((font-loader font-loader))
 169   (let ((pairs nil))
 170     (maphash (lambda (k v)
 171                (let* ((left-index (ldb (byte 16 16) k))
 172                       (right-index (ldb (byte 16 0) k))
 173                       (left (index-glyph left-index font-loader))
 174                       (right (index-glyph right-index font-loader)))
 175                  (push (list left right v) pairs)))
 176              (kerning-table font-loader))
 177     pairs))