Merge pull request #10 from phoe-trash/master
[vecto.git] / text.lisp
bloba7dac0fed2b3fde01426a2c2e741c8875ab71402
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 $
29 (in-package #:vecto)
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)))
42 (defun glyph-path-point (point)
43 (paths:make-point (zpb-ttf:x point)
44 (zpb-ttf:y point)))
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)))))))))
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-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)
86 matrix))))))
87 paths))
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)
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)))
105 (defun empty-bounding-box ()
106 (vector most-positive-fixnum most-positive-fixnum
107 most-negative-fixnum most-negative-fixnum))
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)
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))))
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)))