text.lisp

   1 ;;; Copyright (c) 2007 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 ;;; $Id: text.lisp,v 1.8 2007/09/21 17:39:36 xach Exp $
  28
  29 (in-package #:vecto)
  30
  31 (defclass font ()
  32   ((loader
  33     :initarg :loader
  34     :accessor loader)
  35    (transform-matrix
  36     :initarg :transform-matrix
  37     :accessor transform-matrix)
  38    (size
  39     :initarg :size
  40     :accessor size)))
  41
  42 (defun glyph-path-point (point)
  43   (paths:make-point (zpb-ttf:x point)
  44                     (zpb-ttf:y point)))
  45
  46 (defun glyph-paths (glyph)
  47   (let* ((paths '())
  48          (path nil))
  49     (zpb-ttf:do-contours (contour glyph (nreverse paths))
  50       (when (plusp (length contour))
  51         (let ((first-point (aref contour 0)))
  52           (setf path (paths:create-path :closed-polyline))
  53           (push path paths)
  54           (paths:path-reset path (glyph-path-point first-point))
  55           (zpb-ttf:do-contour-segments* (control end)
  56               contour
  57             (if control
  58                 (paths:path-extend path (paths:make-bezier-curve
  59                                          (list (glyph-path-point control)))
  60                                    (glyph-path-point end))
  61                 (paths:path-extend path (paths:make-straight-line)
  62                                    (glyph-path-point end)))))))))
  63
  64 (defun string-glyphs (string loader)
  65   "Return STRING converted to a list of ZPB-TTF glyph objects from FONT."
  66   (map 'list (lambda (char) (zpb-ttf:find-glyph char loader)) string))
  67
  68 (defun string-primitive-paths (x y string font &key (character-spacing 1.0d0))
  69   "Return the paths of STRING, transformed by the font scale of FONT."
  70   (let ((glyphs (string-glyphs string (loader font)))
  71         (loader (loader font))
  72         (matrix (mult (transform-matrix font) (translation-matrix x y)))
  73         (paths '()))
  74     (loop for (glyph . rest) on glyphs do
  75           (let ((glyph-paths (glyph-paths glyph))
  76                 (fun (make-transform-function matrix)))
  77             (dolist (path glyph-paths)
  78               (push (transform-path path fun) paths))
  79             (when rest
  80               (let* ((next (first rest))
  81                      (offset (+ (zpb-ttf:advance-width glyph)
  82                                 (zpb-ttf:kerning-offset glyph next loader))))
  83                 (setf matrix (nmult (translation-matrix (* offset
  84                                                            character-spacing)
  85                                                         0)
  86                                     matrix))))))
  87     paths))
  88
  89 (defun nmerge-bounding-boxes (b1 b2)
  90   "Create a minimal bounding box that covers both B1 and B2 and
  91 destructively update B1 with its values. Returns the new box."
  92   (setf (xmin b1) (min (xmin b1) (xmin b2))
  93         (ymin b1) (min (ymin b1) (ymin b2))
  94         (xmax b1) (max (xmax b1) (xmax b2))
  95         (ymax b1) (max (ymax b1) (ymax b2)))
  96   b1)
  97
  98 (defun advance-bounding-box (bbox offset)
  99   "Return a bounding box advanced OFFSET units horizontally."
 100   (vector (+ (xmin bbox) offset)
 101           (ymin bbox)
 102           (+ (xmax bbox) offset)
 103           (ymax bbox)))
 104
 105 (defun empty-bounding-box ()
 106   (vector most-positive-fixnum most-positive-fixnum
 107           most-negative-fixnum most-negative-fixnum))
 108
 109 (defun ntransform-bounding-box (bbox fun)
 110   "Return BBOX transformed by FUN; destructively modifies BBOX
 111 with the new values."
 112   (setf (values (xmin bbox) (ymin bbox))
 113         (funcall fun (xmin bbox) (ymin bbox))
 114         (values (xmax bbox) (ymax bbox))
 115         (funcall fun (xmax bbox) (ymax bbox)))
 116   bbox)
 117
 118 (defun loader-font-scale (size loader)
 119   "Return the horizontal and vertical scaling needed to draw the
 120 glyphs of LOADER at SIZE units."
 121   (float (/ size (zpb-ttf:units/em loader))))
 122
 123 (defun string-bounding-box (string size loader &key (character-spacing 1.0d0))
 124   (let* ((bbox (empty-bounding-box))
 125          (scale (loader-font-scale size loader))
 126          (fun (make-transform-function (scaling-matrix scale scale)))
 127          (glyphs (string-glyphs string loader))
 128          (offset 0))
 129     (loop for (glyph . rest) on glyphs do
 130           (let ((glyph-box (advance-bounding-box (bounding-box glyph)
 131                                                  (* offset character-spacing))))
 132             (setf bbox (nmerge-bounding-boxes bbox glyph-box))
 133             (incf offset (zpb-ttf:advance-width glyph))
 134             (when rest
 135               (let* ((next-glyph (first rest))
 136                      (kerning (zpb-ttf:kerning-offset glyph next-glyph loader)))
 137                 (incf offset kerning)))))
 138     (ntransform-bounding-box bbox fun)))