1 ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved
3 ;;; Redistribution and use in source and binary forms, with or without
4 ;;; modification, are permitted provided that the following conditions
7 ;;; * Redistributions of source code must retain the above copyright
8 ;;; notice, this list of conditions and the following disclaimer.
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.
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.
27 ;;; $Id: text.lisp,v 1.8 2007/09/21 17:39:36 xach Exp $
36 :initarg
:transform-matrix
37 :accessor transform-matrix
)
42 (defun glyph-path-point (point)
43 (paths:make-point
(zpb-ttf:x point
)
46 (defun glyph-paths (glyph)
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
:polygon
))
54 (paths:path-reset path
(glyph-path-point first-point
))
55 (zpb-ttf:do-contour-segments
* (control end
)
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
)))))))))
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
))
68 (defun string-paths (x y string font
)
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
)))
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
))
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
0)
87 (defun nmerge-bounding-boxes (b1 b2
)
88 "Create a minimal bounding box that covers both B1 and B2 and
89 destructively update B1 with its values. Returns the new box."
90 (setf (xmin b1
) (min (xmin b1
) (xmin b2
))
91 (ymin b1
) (min (ymin b1
) (ymin b2
))
92 (xmax b1
) (max (xmax b1
) (xmax b2
))
93 (ymax b1
) (max (ymax b1
) (ymax b2
)))
96 (defun advance-bounding-box (bbox offset
)
97 "Return a bounding box advanced OFFSET units horizontally."
98 (vector (+ (xmin bbox
) offset
)
100 (+ (xmax bbox
) offset
)
103 (defun empty-bounding-box ()
104 (vector most-positive-fixnum most-positive-fixnum
105 most-negative-fixnum most-negative-fixnum
))
107 (defun ntransform-bounding-box (bbox fun
)
108 "Return BBOX transformed by FUN; destructively modifies BBOX
109 with the new values."
110 (setf (values (xmin bbox
) (ymin bbox
))
111 (funcall fun
(xmin bbox
) (ymin bbox
))
112 (values (xmax bbox
) (ymax bbox
))
113 (funcall fun
(xmax bbox
) (ymax bbox
)))
116 (defun loader-font-scale (size loader
)
117 "Return the horizontal and vertical scaling needed to draw the
118 glyphs of LOADER at SIZE units."
119 (float (/ size
(zpb-ttf:units
/em loader
))))
121 (defun string-bounding-box (string size loader
)
122 (let* ((bbox (empty-bounding-box))
123 (scale (loader-font-scale size loader
))
124 (fun (make-transform-function (scaling-matrix scale scale
)))
125 (glyphs (string-glyphs string loader
))
127 (loop for
(glyph . rest
) on glyphs do
128 (let ((glyph-box (advance-bounding-box (bounding-box glyph
) offset
)))
129 (setf bbox
(nmerge-bounding-boxes bbox glyph-box
))
130 (incf offset
(zpb-ttf:advance-width glyph
))
132 (let* ((next-glyph (first rest
))
133 (kerning (zpb-ttf:kerning-offset glyph next-glyph loader
)))
134 (incf offset kerning
)))))
135 (ntransform-bounding-box bbox fun
)))