Re-add coordinates to COMPOSE
[vecto.git] / user-drawing.lisp
blobf6aaa31165f61b2831f1d8611f3d9810d72651a2
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: user-drawing.lisp,v 1.21 2007/10/01 14:12:55 xach Exp $
29 (in-package #:vecto)
31 (defvar *graphics-state*)
32 (setf (documentation '*graphics-state* 'variable)
33 "The currently active graphics state. Bound for the
34 duration of WITH-GRAPICS-STATE.")
36 ;;; Low-level path construction
38 (defun %move-to (state x y)
39 (let ((path (paths:create-path :open-polyline)))
40 (push (setf (path state) path) (paths state))
41 (paths:path-reset path (paths:make-point x y))))
43 (defun %line-to (state x y)
44 (paths:path-extend (path state) (paths:make-straight-line)
45 (paths:make-point x y)))
47 (defun %curve-to (state cx1 cy1 cx2 cy2 x y)
48 "Draw a cubic Bezier curve from the current point to (x,y)
49 through two control points."
50 (let ((control-point-1 (paths:make-point cx1 cy1))
51 (control-point-2 (paths:make-point cx2 cy2))
52 (end-point (paths:make-point x y)))
53 (paths:path-extend (path state)
54 (paths:make-bezier-curve (list control-point-1
55 control-point-2))
56 end-point)))
58 (defun %quadratic-to (state cx cy x y)
59 "Draw a quadratic Bezier curve from the current point to (x,y)
60 through one control point."
61 (paths:path-extend (path state)
62 (paths:make-bezier-curve (list (paths:make-point cx cy)))
63 (paths:make-point x y)))
65 (defun draw-arc-curves (curves)
66 (destructuring-bind (((startx . starty) &rest ignored-curve)
67 &rest ignored-curves)
68 curves
69 (declare (ignore ignored-curve ignored-curves))
70 (if (path *graphics-state*)
71 (line-to startx starty)
72 (move-to startx starty)))
73 (loop for ((x1 . y1)
74 (cx1 . cy1)
75 (cx2 . cy2)
76 (x2 . y2)) in curves
77 do (curve-to cx1 cy1 cx2 cy2 x2 y2)))
79 (defun %close-subpath (state)
80 (setf (paths::path-type (path state)) :closed-polyline))
82 ;;; Clipping path
84 (defun %end-path-no-op (state)
85 (after-painting state))
87 (defun %clip-path (state)
88 (call-after-painting state
89 (make-clipping-path-function state :nonzero-winding)))
91 (defun %even-odd-clip-path (state)
92 (call-after-painting state
93 (make-clipping-path-function state :even-odd)))
95 ;;; Text
97 (defun %get-font (state file)
98 (find-font-loader state file))
100 (defun %set-font (state loader size)
101 (let* ((scale (loader-font-scale size loader))
102 (matrix (scaling-matrix scale scale)))
103 (setf (font state)
104 (make-instance 'font
105 :loader loader
106 :transform-matrix matrix
107 :size size))))
109 (defun %string-paths (state x y string)
110 (let ((font (font state)))
111 (unless font
112 (error "No font currently set"))
113 (string-primitive-paths x y string font
114 :character-spacing (character-spacing state))))
116 (defun %draw-string (state x y string)
117 (draw-paths/state (%string-paths state x y string)
118 state))
120 (defun %draw-centered-string (state x y string)
121 (let* ((font (font state))
122 (bbox
123 (string-bounding-box string
124 (size font)
125 (loader font)
126 :character-spacing (character-spacing state)))
127 (xmin (xmin bbox))
128 (width/2 (/ (- (xmax bbox) xmin) 2.0)))
129 (%draw-string state (- x (+ width/2 xmin)) y string)))
131 (defun string-paths (x y string)
132 (setf (paths *graphics-state*)
133 (append (paths *graphics-state*)
134 (%string-paths *graphics-state* x y string)))
135 (values))
137 (defun centered-string-paths (x y string)
138 (let* ((font (font *graphics-state*))
139 (bbox (string-bounding-box string (size font) (loader font)))
140 (width/2 (/ (- (xmax bbox) (xmin bbox)) 2.0)))
141 (setf (paths *graphics-state*)
142 (append (paths *graphics-state*)
143 (%string-paths *graphics-state* (- x width/2) y string)))
144 (values)))
147 ;;; Low-level transforms
149 (defun %translate (state tx ty)
150 (apply-matrix state (translation-matrix tx ty)))
152 (defun %scale (state sx sy)
153 (apply-matrix state (scaling-matrix sx sy)))
155 (defun %skew (state x y)
156 (apply-matrix state (skewing-matrix x y)))
158 (defun %rotate (state radians)
159 (apply-matrix state (rotation-matrix radians)))
161 ;;; User-level commands
163 (defun move-to (x y)
164 (%move-to *graphics-state* x y))
166 (defun line-to (x y)
167 (%line-to *graphics-state* x y))
169 (defun curve-to (cx1 cy1 cx2 cy2 x y)
170 (%curve-to *graphics-state* cx1 cy1 cx2 cy2 x y))
172 (defun quadratic-to (cx cy x y)
173 (%quadratic-to *graphics-state* cx cy x y))
175 (defun arc (cx cy r theta1 theta2)
176 (loop while (< theta2 theta1) do (incf theta2 (* 2 pi)))
177 (let ((curves
178 (approximate-elliptical-arc cx cy r r 0 theta1 theta2)))
179 (draw-arc-curves curves)))
181 (defun arcn (cx cy r theta1 theta2)
182 (loop while (< theta1 theta2) do (decf theta2 (* 2 pi)))
183 (let ((curves (approximate-elliptical-arc cx cy r r 0 theta2 theta1)))
184 (draw-arc-curves (nreverse (mapcar #'nreverse curves)))))
186 (defun ellipse-arc (cx cy rx ry theta eta1 eta2)
187 (loop while (< eta2 eta1) do (incf eta2 (* 2 pi)))
188 (let ((curves (approximate-elliptical-arc cx cy rx ry theta eta1 eta2)))
189 (draw-arc-curves curves)))
191 (defun ellipse-arcn (cx cy rx ry theta eta1 eta2)
192 (loop while (< eta1 eta2) do (decf eta2 (* 2 pi)))
193 (let ((curves (approximate-elliptical-arc cx cy rx ry theta eta2 eta1)))
194 (draw-arc-curves (nreverse (mapcar #'nreverse curves)))))
198 (defun close-subpath ()
199 (%close-subpath *graphics-state*))
201 (defun end-path-no-op ()
202 (%end-path-no-op *graphics-state*)
203 (clear-paths *graphics-state*))
205 (defun clip-path ()
206 (%clip-path *graphics-state*))
208 (defun even-odd-clip-path ()
209 (%even-odd-clip-path *graphics-state*))
211 (defun get-font (file)
212 (%get-font *graphics-state* file))
214 (defun set-font (font size)
215 (%set-font *graphics-state* font size))
217 (defun set-character-spacing (spacing)
218 (setf (character-spacing *graphics-state*) spacing))
220 (defun draw-string (x y string)
221 (%draw-string *graphics-state* x y string))
223 (defun draw-centered-string (x y string)
224 (%draw-centered-string *graphics-state* x y string))
226 (defun set-dash-pattern (vector phase)
227 (if (zerop (length vector))
228 (setf (dash-vector *graphics-state*) nil
229 (dash-phase *graphics-state*) nil)
230 (setf (dash-vector *graphics-state*) vector
231 (dash-phase *graphics-state*) phase)))
233 (defun set-line-cap (style)
234 (assert (member style '(:butt :square :round)))
235 (setf (cap-style *graphics-state*) style))
237 (defun set-line-join (style)
238 (assert (member style '(:bevel :miter :round)))
239 (setf (join-style *graphics-state*) (if (eql style :bevel) :none style)))
241 (defun set-line-width (width)
242 (setf (line-width *graphics-state*) width))
244 (defun set-rgba-color (color r g b a)
245 (setf (red color) (clamp-range 0.0 r 1.0)
246 (green color) (clamp-range 0.0 g 1.0)
247 (blue color) (clamp-range 0.0 b 1.0)
248 (alpha color) (clamp-range 0.0 a 1.0))
249 color)
251 (defun set-rgb-color (color r g b)
252 (setf (red color) (clamp-range 0.0 r 1.0)
253 (green color) (clamp-range 0.0 g 1.0)
254 (blue color) (clamp-range 0.0 b 1.0)
255 (alpha color) 1.0)
256 color)
258 (defun set-rgb-stroke (r g b)
259 (set-rgb-color (stroke-color *graphics-state*) r g b))
261 (defun set-rgba-stroke (r g b a)
262 (set-rgba-color (stroke-color *graphics-state*) r g b a))
264 (defun set-rgb-fill (r g b)
265 (clear-fill-source *graphics-state*)
266 (set-rgb-color (fill-color *graphics-state*) r g b))
268 (defun set-rgba-fill (r g b a)
269 (clear-fill-source *graphics-state*)
270 (set-rgba-color (fill-color *graphics-state*) r g b a))
272 (defun stroke ()
273 (draw-stroked-paths *graphics-state*)
274 (clear-paths *graphics-state*))
276 (defun stroke-to-paths ()
277 (let ((paths (state-stroke-paths *graphics-state*)))
278 (clear-paths *graphics-state*)
279 (setf (paths *graphics-state*) paths)
280 (%close-subpath *graphics-state*)))
282 (defun fill-path ()
283 (draw-filled-paths *graphics-state*)
284 (after-painting *graphics-state*)
285 (clear-paths *graphics-state*))
287 (defun even-odd-fill ()
288 (draw-even-odd-filled-paths *graphics-state*)
289 (after-painting *graphics-state*)
290 (clear-paths *graphics-state*))
292 (defun fill-and-stroke ()
293 (draw-filled-paths *graphics-state*)
294 (draw-stroked-paths *graphics-state*)
295 (after-painting *graphics-state*)
296 (clear-paths *graphics-state*))
298 (defun even-odd-fill-and-stroke ()
299 (draw-even-odd-filled-paths *graphics-state*)
300 (draw-stroked-paths *graphics-state*)
301 (after-painting *graphics-state*)
302 (clear-paths *graphics-state*))
305 (defun clear-canvas ()
306 (let ((color (fill-color *graphics-state*)))
307 (fill-image (image-data *graphics-state*)
308 (red color)
309 (green color)
310 (blue color)
311 (alpha color))))
313 (defun translate (x y)
314 (%translate *graphics-state* x y))
316 (defun scale (x y)
317 (%scale *graphics-state* x y))
319 (defun skew (x y)
320 (%skew *graphics-state* x y))
322 (defun rotate (radians)
323 (%rotate *graphics-state* radians))
325 (defun rotate-degrees (degrees)
326 (%rotate *graphics-state* (* (/ pi 180) degrees)))
328 (defgeneric compose (layer x y))
330 (defun save-png (file)
331 (zpng:write-png (image *graphics-state*) file))
333 (defun save-png-stream (stream)
334 (zpng:write-png-stream (image *graphics-state*) stream))
336 (defun zpng-object ()
337 (image *graphics-state*))
339 (defmacro with-canvas ((&key width height image-data-allocator)
340 &body body)
341 `(let ((*graphics-state* (make-instance 'graphics-state)))
342 (state-image *graphics-state* ,width ,height
343 ,@(when image-data-allocator `(,image-data-allocator)))
344 (unwind-protect
345 (progn
346 ,@body)
347 (clear-state *graphics-state*))))
349 (defmacro with-graphics-state (&body body)
350 `(let ((*graphics-state* (copy *graphics-state*)))
351 ,@body))