/[cl-gd]/cl-gd/strings.lisp
ViewVC logotype

Contents of /cl-gd/strings.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Sun Apr 25 20:34:01 2004 UTC (9 years, 11 months ago) by eweitz
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +0 -0 lines
pre-0.3.2 with bugfix for LW bivalent streams
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*-
2 ;;; $Header: /tiger/var/lib/cvsroots/cl-gd/cl-gd/strings.lisp,v 1.3 2004/04/25 20:34:01 eweitz Exp $
3
4 ;;; Copyright (c) 2003, Dr. Edmund Weitz. All rights reserved.
5
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
8 ;;; are met:
9
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
17
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
30 (in-package :cl-gd)
31
32 (defmacro with-default-font ((font) &body body)
33 "Execute BODY with *DEFAULT-FONT* bound to FONT so that you don't
34 have to provide the FONT keyword/optional argument to string
35 functions. But note that the fonts used for DRAW-STRING/DRAW-CHAR and
36 DRAW-FREETYPE-STRING are incompatible."
37 `(let ((*default-font* ,font))
38 ,@body))
39
40 (defun draw-character (x y char &key up (font *default-font*) (color *default-color*) (image *default-image*))
41 "Draws the character CHAR from font FONT in color COLOR at position
42 \(X,Y). If UP is true the character will be drawn from bottom to top
43 \(rotated 90 degrees). FONT must be one of :TINY, :SMALL, :MEDIUM,
44 :LARGE, :GIANT."
45 (check-type char character)
46 (check-type image image)
47 (with-color-argument
48 (with-transformed-alternative
49 ((x x-transformer)
50 (y y-transformer))
51 (if up
52 (gd-image-char-up (img image) (ecase font
53 ((:tiny) +gd-font-tiny+)
54 ((:small) +gd-font-small+)
55 ((:medium :medium-bold) +gd-font-medium-bold+)
56 ((:large) +gd-font-large+)
57 ((:giant) +gd-font-giant+))
58 x y (char-code char) color)
59 (gd-image-char (img image) (ecase font
60 ((:tiny) +gd-font-tiny+)
61 ((:small) +gd-font-small+)
62 ((:medium :medium-bold) +gd-font-medium-bold+)
63 ((:large) +gd-font-large+)
64 ((:giant) +gd-font-giant+))
65 x y (char-code char) color))))
66 char)
67
68 (defun draw-string (x y string &key up (font *default-font*) (color *default-color*) (image *default-image*))
69 "Draws the string STRING in color COLOR at position \(X,Y). If UP is
70 true the character will be drawn from bottom to top \(rotated 90
71 degrees). FONT must be one of :TINY, :SMALL, :MEDIUM, :LARGE, :GIANT."
72 (check-type string string)
73 (check-type image image)
74 (with-color-argument
75 (with-transformed-alternative
76 ((x x-transformer)
77 (y y-transformer))
78 (with-cstring (c-string string)
79 (if up
80 (gd-image-string-up (img image) (ecase font
81 ((:tiny) +gd-font-tiny+)
82 ((:small) +gd-font-small+)
83 ((:medium :medium-bold) +gd-font-medium-bold+)
84 ((:large) +gd-font-large+)
85 ((:giant) +gd-font-giant+))
86 x y c-string color)
87 (gd-image-string (img image) (ecase font
88 ((:tiny) +gd-font-tiny+)
89 ((:small) +gd-font-small+)
90 ((:medium :medium-bold) +gd-font-medium-bold+)
91 ((:large) +gd-font-large+)
92 ((:giant) +gd-font-giant+))
93 x y c-string color)))))
94 string)
95
96 (defun draw-freetype-string (x y string
97 &key (anti-aliased t)
98 (point-size 12.0d0)
99 (angle 0.0d0)
100 (convert-chars t)
101 line-spacing
102 (font-name *default-font*)
103 do-not-draw
104 (color *default-color*)
105 (image *default-image*))
106 "Draws the string STRING in color COLOR at position \(X,Y) using the
107 FreeType library. FONT-NAME is the full path \(a pathname or a string)
108 to a TrueType font file, or a font face name if the GDFONTPATH
109 environment variable or FreeType's DEFAULT_FONTPATH variable have been
110 set intelligently. The string may be arbitrarily scaled \(POINT-SIZE)
111 and rotated \(ANGLE in radians). The direction of rotation is
112 counter-clockwise, with 0 radians \(0 degrees) at 3 o'clock and PI/2
113 radians \(90 degrees) at 12 o'clock. Note that the ANGLE argument is
114 purposefully _not_ affected by WITH-TRANSFORMATION. If ANTI-ALIASED if
115 false, anti-aliasing is disabled. It is enabled by default. To output
116 multiline text with a specific line spacing, provide a value for
117 LINE-SPACING, expressed as a multiple of the font height. The default
118 is to use 1.05. The string may contain XML character entity references
119 like \"À\". If CONVERT-CHARS is true \(which is the default)
120 characters of STRING with CHAR-CODE greater than 127 are converted
121 accordingly. This of course pre-supposes that your Lisp's CHAR-CODE
122 function returns ISO/IEC 10646 (Unicode) character codes.
123
124 The return value is an array containing 8 elements representing the 4
125 corner coordinates \(lower left, lower right, upper right, upper left)
126 of the bounding rectangle around the string that was drawn. The points
127 are relative to the text regardless of the angle, so \"upper left\"
128 means in the top left-hand corner seeing the text horizontally. Set
129 DO-NOT-DRAW to true to get the bounding rectangle without
130 rendering. This is a relatively cheap operation if followed by a
131 rendering of the same string, because of the caching of the partial
132 rendering during bounding rectangle calculation."
133 (check-type string string)
134 (check-type font-name (or pathname string))
135 (check-type color integer)
136 (check-type image image)
137 (with-transformed-alternative
138 ((x x-transformer)
139 (y y-transformer)
140 ((deref-array c-bounding-rectangle '(:array :int) i) x-inv-transformer)
141 ((deref-array c-bounding-rectangle '(:array :int) (1+ i)) y-inv-transformer))
142 (when (pathnamep font-name)
143 (setq font-name (namestring font-name)))
144 (when convert-chars
145 (setq string (convert-to-char-references string)))
146 (with-cstring (c-font-name font-name)
147 (with-cstring (c-string string)
148 (let ((c-bounding-rectangle (allocate-foreign-object :int 8)))
149 (unwind-protect
150 (let ((msg (convert-from-cstring
151 (cond (line-spacing
152 (with-foreign-object (strex 'gd-ft-string-extra)
153 (setf (get-slot-value strex
154 'gd-ft-string-extra
155 'flags)
156 +gd-ftex-linespace+
157 (get-slot-value strex
158 'gd-ft-string-extra
159 'line-spacing)
160 (coerce line-spacing 'double-float))
161 (gd-image-string-ft-ex (if do-not-draw
162 *null-image*
163 (img image))
164 c-bounding-rectangle
165 (if anti-aliased color (- color))
166 c-font-name
167 (coerce point-size 'double-float)
168 (coerce angle 'double-float)
169 x y
170 c-string
171 strex)))
172 (t
173 (gd-image-string-ft (img (if do-not-draw
174 *null-image*
175 image))
176 c-bounding-rectangle
177 (if anti-aliased color (- color))
178 c-font-name
179 (coerce point-size 'double-float)
180 (coerce angle 'double-float)
181 x y
182 c-string))))))
183 (when msg
184 (error "Error in FreeType library: ~A" msg))
185 (let ((bounding-rectangle (make-array 8)))
186 ;; strange iteration due to WITH-TRANSFORMED-ALTERNATIVE
187 (loop for i below 8 by 2 do
188 (setf (aref bounding-rectangle i)
189 (deref-array c-bounding-rectangle '(:array :int) i))
190 (setf (aref bounding-rectangle (1+ i))
191 (deref-array c-bounding-rectangle '(:array :int) (1+ i))))
192 bounding-rectangle))
193 (free-foreign-object c-bounding-rectangle)))))))

  ViewVC Help
Powered by ViewVC 1.1.5