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: drawing.lisp,v 1.17 2007/10/01 19:05:13 xach Exp $
34 (deftype vector-index
()
35 `(mod ,array-dimension-limit
))
37 (deftype octet-vector
()
38 '(simple-array (unsigned-byte 8) (*)))
40 (defun nonzero-winding-alpha (alpha)
41 (min 255 (abs alpha
)))
43 (defun even-odd-alpha (alpha)
44 (let ((value (mod alpha
512)))
45 (min 255 (if (< value
256) value
(- 512 value
)))))
47 ;; ( (t) = (a) * (b) + 0x80, ( ( ( (t)>>8 ) + (t) )>>8 ) )
50 (let ((temp (+ (* a b
) #x80
)))
51 (logand #xFF
(ash (+ (ash temp -
8) temp
) -
8))))
54 (logand #xFF
(+ p
(imult a
(- q p
)))))
56 (defun prelerp (p q a
)
57 (logand #xFF
(- (+ p q
) (imult a p
))))
59 (defun draw-function (data width height fill-source alpha-fun
)
60 "From http://www.teamten.com/lawrence/graphics/premultiplication/"
61 (declare (ignore height
))
63 (multiple-value-bind (r.fg g.fg b.fg a.fg
)
64 (funcall fill-source x y
)
65 (setf alpha
(funcall alpha-fun alpha
))
67 (let* ((i (* +png-channels
+ (+ x
(* y width
))))
68 (r.bg
(aref data
(+ i
0)))
69 (g.bg
(aref data
(+ i
1)))
70 (b.bg
(aref data
(+ i
2)))
71 (a.bg
(aref data
(+ i
3)))
72 (a.fg
(imult alpha a.fg
))
73 (gamma (prelerp a.fg a.bg a.bg
)))
75 (let ((value (lerp (imult bg a.bg
) fg a.fg
)))
76 (float-octet (/ value gamma
)))))
78 (setf (aref data
(+ i
0)) (blend r.fg r.bg
)
79 (aref data
(+ i
1)) (blend g.fg g.bg
)
80 (aref data
(+ i
2)) (blend b.fg b.bg
)))
81 (setf (aref data
(+ i
3)) gamma
)))))))
83 (defun draw-function/clipped
(data clip-data
87 "Like DRAW-FUNCTION, but uses uses the clipping channel."
88 (declare (ignore height
))
90 (let* ((clip-index (+ x
(* y width
)))
91 (clip (aref clip-data clip-index
)))
92 (setf alpha
(imult clip
(funcall alpha-fun alpha
)))
94 (multiple-value-bind (r.fg g.fg b.fg a.fg
)
95 (funcall fill-source x y
)
96 (let* ((i (* clip-index
+png-channels
+))
97 (r.bg
(aref data
(+ i
0)))
98 (g.bg
(aref data
(+ i
1)))
99 (b.bg
(aref data
(+ i
2)))
100 (a.bg
(aref data
(+ i
3)))
101 (a.fg
(imult alpha a.fg
))
102 (gamma (prelerp a.fg a.bg a.bg
)))
103 (flet ((blend (fg bg
)
104 (let ((value (lerp (imult bg a.bg
) fg a.fg
)))
105 (float-octet (/ value gamma
)))))
106 (unless (zerop gamma
)
107 (setf (aref data
(+ i
0)) (blend r.fg r.bg
)
108 (aref data
(+ i
1)) (blend g.fg g.bg
)
109 (aref data
(+ i
2)) (blend b.fg b.bg
)))
110 (setf (aref data
(+ i
3)) gamma
))))))))
112 (defun make-draw-function (data clipping-path
116 (if (emptyp clipping-path
)
117 (draw-function data width height fill-source alpha-fun
)
118 (draw-function/clipped data
(clipping-data clipping-path
)
123 (defun intersect-clipping-paths (data temp
)
124 (declare (type (simple-array (unsigned-byte 8) (*)) data temp
))
125 (map-into data
#'imult temp data
))
127 (defun draw-clipping-path-function (data width height alpha-fun
)
128 (declare (ignore height
)
129 (type (simple-array (unsigned-byte 8) (*)) data
))
131 (let ((i (+ x
(* width y
))))
132 (let ((alpha (funcall alpha-fun alpha
)))
133 (setf (aref data i
) alpha
)))))
135 (defun draw-paths (&key width height paths
138 "Use DRAW-FUNCTION as a callback for the cells sweep function
139 for the set of paths PATHS."
140 (let ((state (aa:make-state
))
141 (paths (mapcar (lambda (path)
142 ;; FIXME: previous versions lacked
143 ;; paths:path-clone, and this broke fill &
144 ;; stroke because transform-path damages the
145 ;; paths. It would be nicer if transform-path
146 ;; wasn't destructive, since I didn't expect
148 (transform-path (paths:path-clone path
)
151 (vectors:update-state state paths
)
152 (aa:cells-sweep
/rectangle state
0 0 width height draw-function
)))
154 ;;; FIXME: this was added for drawing text paths, but the text
155 ;;; rendering mode could be changed in the future, making it a little
156 ;;; silly to have a fixed draw-function.
158 (defun draw-paths/state
(paths state
)
159 (draw-paths :paths paths
161 :height
(height state
)
162 :transform-function
(transform-function state
)
163 :draw-function
(fill-draw-function state
)))
165 (defun fill-image (image-data red green blue alpha
)
166 "Completely fill IMAGE with the given colors."
167 (let ((r (float-octet red
))
168 (g (float-octet green
))
169 (b (float-octet blue
))
170 (a (float-octet alpha
)))
175 ((<= (length image-data
) k
))
176 (setf (aref image-data h
) r
177 (aref image-data i
) g
178 (aref image-data j
) b
179 (aref image-data k
) a
))))
181 (defun color-source-function (color)
182 (let ((red (float-octet (red color
)))
183 (green (float-octet (green color
)))
184 (blue (float-octet (blue color
)))
185 (alpha (float-octet (alpha color
))))
187 (declare (ignore x y
))
188 (values red green blue alpha
))))
190 (defun fill-source-function (state)
191 (or (fill-source state
)
192 (color-source-function (fill-color state
))))
194 (defun stroke-source-function (state)
195 (color-source-function (stroke-color state
)))
197 (defun state-draw-function (state fill-source fill-style
)
198 "Create a draw function for the graphics state STATE."
199 (make-draw-function (image-data state
)
200 (clipping-path state
)
205 (:even-odd
#'even-odd-alpha
)
206 (:nonzero-winding
#'nonzero-winding-alpha
))))
208 (defun stroke-draw-function (state)
209 (state-draw-function state
210 (stroke-source-function state
)
213 (defun fill-draw-function (state)
214 (state-draw-function state
215 (fill-source-function state
)
218 (defun even-odd-fill-draw-function (state)
219 (state-draw-function state
220 (fill-source-function state
)
223 (defun tolerance-scale (state)
224 (let ((matrix (transform-matrix state
)))
225 (abs (/ 1.0 (min (transform-matrix-x-scale matrix
)
226 (transform-matrix-y-scale matrix
))))))
228 (defun state-stroke-paths (state)
229 "Compute the outline paths of the strokes for the current paths of STATE."
230 (let ((paths (dash-paths (paths state
)
233 (paths:*bezier-distance-tolerance
*
234 (* paths
:*bezier-distance-tolerance
* (tolerance-scale state
))))
236 :line-width
(line-width state
)
237 :join-style
(join-style state
)
238 :cap-style
(cap-style state
))))
240 (defun draw-stroked-paths (state)
241 "Create a set of paths representing a stroking of the current
242 paths of STATE, and draw them to the image."
243 (draw-paths :paths
(state-stroke-paths state
)
245 :height
(height state
)
246 :transform-function
(transform-function state
)
247 :draw-function
(stroke-draw-function state
)))
249 (defun close-paths (paths)
251 (setf (paths::path-type path
) :closed-polyline
)))
253 (defun draw-filled-paths (state)
254 "Fill the paths of STATE into the image."
255 (close-paths (paths state
))
256 (draw-paths :paths
(paths state
)
258 :height
(height state
)
259 :transform-function
(transform-function state
)
260 :draw-function
(fill-draw-function state
)))
262 (defun draw-even-odd-filled-paths (state)
263 "Fill the paths of STATE into the image."
264 (close-paths (paths state
))
265 (draw-paths :paths
(paths state
)
267 :height
(height state
)
268 :transform-function
(transform-function state
)
269 :draw-function
(even-odd-fill-draw-function state
)))
271 (defun draw-clipping-path (state alpha-fun
)
272 (let ((data (writable-clipping-data (clipping-path state
)))
273 (scratch (scratch (clipping-path state
)))
274 (width (width state
))
275 (height (height state
)))
276 (declare (type octet-vector data scratch
))
278 (draw-paths :paths
(paths state
)
280 :height
(height state
)
281 :transform-function
(transform-function state
)
282 :draw-function
(draw-clipping-path-function scratch
286 (intersect-clipping-paths data scratch
)))
288 (defun make-clipping-path-function (state type
)
292 (draw-clipping-path state
#'nonzero-winding-alpha
)))
295 (draw-clipping-path state
#'even-odd-alpha
)))))