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-1 (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     (declare (ignore search-range entry-selector range-shift))
  45     (dotimes (i pair-count)
  46       (setf (gethash (read-uint32 stream) table)
  47             (read-int16 stream)))))
  48
  49 (defmethod load-kerning-subtable ((font-loader font-loader) format)
  50   (when (/= 1 format)
  51     (error 'unsupported-format
  52            :description "kerning subtable"
  53            :size 1
  54            :expected-values (list 1)
  55            :actual-value format))
  56   (load-kerning-format-1 (kerning-table font-loader)
  57                          (input-stream font-loader)))
  58
  59 (defmethod load-kern-info ((font-loader font-loader))
  60   (when (table-exists-p "kern" font-loader)
  61     (seek-to-table "kern" font-loader)
  62     (let* ((stream (input-stream font-loader))
  63            (maybe-version (read-uint16 stream))
  64            (maybe-table-count (read-uint16 stream))
  65            (version 0)
  66            (table-count 0))
  67       ;; These shenanegins are because Apple documents one style of
  68       ;; kern table and Microsoft documents another. This code
  69       ;; implements Microsoft's version.
  70       ;; See:
  71       ;;  http://developer.apple.com/fonts/TTRefMan/RM06/Chap6kern.html
  72       ;;  https://docs.microsoft.com/en-us/typography/opentype/spec/kern
  73       (if (zerop version)
  74           (setf version maybe-version
  75                 table-count maybe-table-count)
  76           (setf version (logand (ash maybe-version 16) maybe-table-count)
  77                 table-count (read-uint32 stream)))
  78       (check-version "\"kern\" table" version 0)
  79       (dotimes (i table-count)
  80         (let ((version (read-uint16 stream))
  81               (length (read-uint16 stream))
  82               (coverage-flags (read-uint8 stream))
  83               (format (read-uint8 stream)))
  84           (declare (ignore version length coverage-flags))
  85           (load-kerning-subtable font-loader format))))))
  86
  87 (defmethod all-kerning-pairs ((font-loader font-loader))
  88   (let ((pairs nil))
  89     (maphash (lambda (k v)
  90                (let* ((left-index (ldb (byte 16 16) k))
  91                       (right-index (ldb (byte 16 0) k))
  92                       (left (index-glyph left-index font-loader))
  93                       (right (index-glyph right-index font-loader)))
  94                  (push (list left right v) pairs)))
  95              (kerning-table font-loader))
  96     pairs))