/[mcclim]/mcclim/bezier.lisp
ViewVC logotype

Contents of /mcclim/bezier.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Tue Jul 17 06:36:01 2007 UTC (6 years, 9 months ago) by crhodes
Branch: MAIN
CVS Tags: McCLIM-0-9-5, McCLIM-0-9-6, HEAD
Changes since 1.2: +20 -16 lines
In bezier area/curve convolution, don't put the area (pen) down quite so
often: reduces redundant areas in unions from draw-path in gsharp.

(Also rename convlute -> convolve)
1 (in-package :clim-internals)
2
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4 ;;;
5 ;;; Utilities
6
7 (defun point-to-complex (point)
8 "convert a point to a complex number"
9 (complex (point-x point) (point-y point)))
10
11 (defun complex-to-point (complex)
12 "convert a complex number to a point"
13 (make-point (realpart complex) (imagpart complex)))
14
15 (defun distance (p0 p1)
16 "return the euclidian distance between two points"
17 (multiple-value-bind (x0 y0) (point-position p0)
18 (multiple-value-bind (x1 y1) (point-position p1)
19 (let* ((dx (- x1 x0))
20 (dx2 (* dx dx))
21 (dy (- y1 y0))
22 (dy2 (* dy dy)))
23 (sqrt (+ dx2 dy2))))))
24
25 (defun part-way (p0 p1 alpha)
26 "return a point that is part way between two other points"
27 (multiple-value-bind (x0 y0) (point-position p0)
28 (multiple-value-bind (x1 y1) (point-position p1)
29 (make-point (+ (* (- 1 alpha) x0) (* alpha x1))
30 (+ (* (- 1 alpha) y0) (* alpha y1))))))
31
32 (defun dot-dist (p p0 p1)
33 "dot distance between a point and a line"
34 (let ((dx (- (point-x p1) (point-x p0)))
35 (dy (- (point-y p1) (point-y p0))))
36 (- (* (point-x p) dy)
37 (* (point-y p) dx))))
38
39 (defun solve-quadratic (a2 a1 a0 &key complex-roots multiple-roots)
40 (when (zerop a2)
41 (return-from solve-quadratic (- (/ a0 a1))))
42 (unless (= a2 1)
43 (setf a1 (/ a1 a2)
44 a0 (/ a0 a2)))
45 (let* ((-a1/2 (- (/ a1 2.0)))
46 (r (- (* -a1/2 -a1/2) a0)))
47 (cond ((zerop r)
48 (if multiple-roots (values -a1/2 -a1/2) -a1/2))
49 ((minusp r)
50 (if complex-roots (values (+ -a1/2 (sqrt r)) (- -a1/2 (sqrt r))) (values)))
51 (t
52 (values (+ -a1/2 (sqrt r)) (- -a1/2 (sqrt r)))))))
53
54 (defun dist (v z)
55 "compute the distance between a point and a vector represented as a complex number"
56 (- (* (realpart z) (point-y v))
57 (* (imagpart z) (point-x v))))
58
59 (defclass bezier-design (design)
60 ((%or :accessor original-region :initform nil)))
61
62 (defgeneric medium-draw-bezier-design* (stream design))
63
64 (defclass bezier-design-output-record (standard-graphics-displayed-output-record)
65 ((stream :initarg :stream)
66 (design :initarg :design)))
67
68 (defmethod initialize-instance :after ((record bezier-design-output-record) &key)
69 (with-slots (design) record
70 (setf (rectangle-edges* record)
71 (bounding-rectangle* design))))
72
73 (defmethod medium-draw-bezier-design* :around ((stream output-recording-stream) design)
74 (with-sheet-medium (medium stream)
75 (let ((transformed-design (transform-region (medium-transformation medium) design)))
76 (when (stream-recording-p stream)
77 (let ((record (make-instance 'bezier-design-output-record
78 :stream stream
79 :design transformed-design)))
80 (stream-add-output-record stream record)))
81 (when (stream-drawing-p stream)
82 (medium-draw-bezier-design* medium design)))))
83
84 (defmethod medium-draw-bezier-design* :around
85 ((medium transform-coordinates-mixin) design)
86 (let* ((tr (medium-transformation medium))
87 (design (transform-region tr design)))
88 (call-next-method medium design)))
89
90 (defmethod replay-output-record ((record bezier-design-output-record) stream &optional
91 (region +everywhere+) (x-offset 0) (y-offset 0))
92 (declare (ignore x-offset y-offset region))
93 (with-slots (design) record
94 (medium-draw-bezier-design* (sheet-medium stream) design)))
95
96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
97 ;;;
98 ;;; Bezier curves and areas
99
100 (defclass bezier-segment ()
101 ((p0 :initarg :p0)
102 (p1 :initarg :p1)
103 (p2 :initarg :p2)
104 (p3 :initarg :p3)))
105
106 (defun make-bezier-segment (p0 p1 p2 p3)
107 (make-instance 'bezier-segment
108 :p0 p0 :p1 p1 :p2 p2 :p3 p3))
109
110 (defclass bounding-rectangle-mixin ()
111 ((min-x) (min-y) (max-x) (max-y)))
112
113 (defmethod bounding-rectangle* ((region bounding-rectangle-mixin))
114 (with-slots (min-x min-y max-x max-y) region
115 (values min-x min-y max-x max-y)))
116
117 (defclass segments-mixin (bounding-rectangle-mixin)
118 ((%segments :initarg :segments :initform '() :reader %segments)))
119
120 (defmethod compute-bounding-rectangle* ((segments-mixin segments-mixin))
121 (multiple-value-bind (final-min-x final-min-y final-max-x final-max-y)
122 (segment-bounding-rectangle (car (%segments segments-mixin)))
123 (loop for segment in (cdr (%segments segments-mixin))
124 do (multiple-value-bind (min-x min-y max-x max-y)
125 (segment-bounding-rectangle segment)
126 (setf final-min-x (min final-min-x min-x)
127 final-min-y (min final-min-y min-y)
128 final-max-x (max final-max-x max-x)
129 final-max-y (max final-max-y max-y))))
130 (values final-min-x final-min-y final-max-x final-max-y)))
131
132 (defmethod initialize-instance :after ((region segments-mixin) &rest args)
133 (declare (ignore args))
134 (multiple-value-bind (computed-min-x computed-min-y computed-max-x computed-max-y)
135 (compute-bounding-rectangle* region)
136 (with-slots (min-x min-y max-x max-y) region
137 (setf min-x computed-min-x
138 min-y computed-min-y
139 max-x computed-max-x
140 max-y computed-max-y))))
141
142 ;;; a path defined as a sequence of Bezier curve segments
143 (defclass bezier-curve (path segments-mixin bounding-rectangle-mixin) ())
144
145 (defun make-bezier-thing (class point-seq)
146 (assert (= (mod (length point-seq) 3) 1))
147 (make-instance class
148 :segments (loop for (p0 p1 p2 p3) on point-seq by #'cdddr
149 until (null p1)
150 collect (make-bezier-segment p0 p1 p2 p3))))
151
152 (defun make-bezier-thing* (class coord-seq)
153 (assert (= (mod (length coord-seq) 6) 2))
154 (make-instance class
155 :segments (loop for (x0 y0 x1 y1 x2 y2 x3 y3 x4 y4)
156 on coord-seq by #'(lambda (x) (nthcdr 6 x))
157 until (null x1)
158 collect (make-bezier-segment
159 (make-point x0 y0)
160 (make-point x1 y1)
161 (make-point x2 y2)
162 (make-point x3 y3)))))
163
164 (defun make-bezier-curve (point-seq)
165 (make-bezier-thing 'bezier-curve point-seq))
166
167 (defun make-bezier-curve* (coord-seq)
168 (make-bezier-thing* 'bezier-curve coord-seq))
169
170 (defun transform-segment (transformation segment)
171 (with-slots (p0 p1 p2 p3) segment
172 (make-bezier-segment (transform-region transformation p0)
173 (transform-region transformation p1)
174 (transform-region transformation p2)
175 (transform-region transformation p3))))
176
177 (defmethod transform-region (transformation (path bezier-curve))
178 (make-instance 'bezier-curve
179 :segments (mapcar (lambda (segment)
180 (transform-segment transformation segment))
181 (%segments path))))
182
183 (defmethod region-equal ((p1 point) (p2 point))
184 (let ((coordinate-epsilon (* #.(expt 2 10) double-float-epsilon)))
185 (and (<= (abs (- (point-x p1) (point-x p2))) coordinate-epsilon)
186 (<= (abs (- (point-y p1) (point-y p2))) coordinate-epsilon))))
187
188 (defmethod region-union ((r1 bezier-curve) (r2 bezier-curve))
189 (let ((p (slot-value (car (last (%segments r1))) 'p3))
190 (seg (car (%segments r2))))
191 (if (region-equal p (slot-value seg 'p0))
192 (with-slots (p1 p2 p3) seg
193 (make-instance 'bezier-curve
194 :segments (append (%segments r1)
195 (cons (make-bezier-segment p p1 p2 p3)
196 (cdr (%segments r2))))))
197 (call-next-method))))
198
199 ;;; an area defined as a closed path of Bezier curve segments
200 (defclass bezier-area (area bezier-design segments-mixin bounding-rectangle-mixin)
201 ((%trans :initarg :transformation :reader transformation :initform +identity-transformation+)))
202
203 (defgeneric close-path (path))
204
205 (defmethod close-path ((path bezier-curve))
206 (let ((segments (%segments path)))
207 (assert (region-equal (slot-value (car segments) 'p0)
208 (slot-value (car (last segments)) 'p3)))
209 (make-instance 'bezier-area :segments segments)))
210
211 (defun path-start (path)
212 (slot-value (car (%segments path)) 'p0))
213
214 (defun path-end (path)
215 (slot-value (car (last (%segments path))) 'p3))
216
217 (defun make-bezier-area (point-seq)
218 (assert (region-equal (car point-seq) (car (last point-seq))))
219 (make-bezier-thing 'bezier-area point-seq))
220
221 (defun make-bezier-area* (coord-seq)
222 (assert (and (coordinate= (car coord-seq) (car (last coord-seq 2)))
223 (coordinate= (cadr coord-seq) (car (last coord-seq)))))
224 (make-bezier-thing* 'bezier-area coord-seq))
225
226 (defmethod segments ((area bezier-area))
227 (let ((tr (transformation area)))
228 (mapcar (lambda (s) (transform-segment tr s)) (%segments area))))
229
230 (defmethod transform-region (transformation (area bezier-area))
231 (let* ((tr (transformation area))
232 (result (if (translation-transformation-p transformation)
233 (make-instance 'bezier-area :segments (%segments area)
234 :transformation
235 (compose-transformations transformation tr))
236 (make-instance 'bezier-area
237 :segments (mapcar (lambda (s) (transform-segment transformation s)) (segments area))))))
238 (when (translation-transformation-p transformation)
239 (setf (original-region result) (or (original-region area) area)))
240 result))
241
242 (defmethod compute-bounding-rectangle* ((area bezier-area))
243 (multiple-value-bind (lx ly ux uy) (call-next-method)
244 (let ((tr (transformation area)))
245 (transform-rectangle* tr lx ly ux uy))))
246
247 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
248 ;;;
249 ;;; Special cases of combined Bezier areas
250
251 ;;; A union of bezier areas. This is not itself a bezier area.
252 (defclass bezier-union (area bezier-design)
253 ((%trans :initarg :transformation :reader transformation :initform +identity-transformation+)
254 (%areas :initarg :areas :initform '() :reader areas)))
255
256 (defmethod transform-region (transformation (union bezier-union))
257 (let* ((tr (transformation union))
258 (new-tr (compose-transformations transformation tr))
259 (result (if (translation-transformation-p transformation)
260 (make-instance 'bezier-union :areas (areas union)
261 :transformation new-tr)
262 (make-instance 'bezier-union
263 :areas (loop for area in (areas union) collect (transform-region new-tr area))))))
264 (when (translation-transformation-p transformation)
265 (setf (original-region result) (or (original-region union) union)))
266 result))
267
268 (defun bounding-rectangle-of-areas (areas)
269 (multiple-value-bind (final-min-x final-min-y final-max-x final-max-y)
270 (bounding-rectangle* (car areas))
271 (loop for area in (cdr areas)
272 do (multiple-value-bind (min-x min-y max-x max-y)
273 (bounding-rectangle* area)
274 (setf final-min-x (min final-min-x min-x)
275 final-min-y (min final-min-y min-y)
276 final-max-x (max final-max-x max-x)
277 final-max-y (max final-max-y max-y))))
278 (values final-min-x final-min-y final-max-x final-max-y)))
279
280 (defmethod bounding-rectangle* ((design bezier-union))
281 (multiple-value-bind (lx ly ux uy)
282 (bounding-rectangle-of-areas (areas design))
283 (transform-rectangle* (transformation design) lx ly ux uy)))
284
285 (defmethod region-union ((r1 bezier-area) (r2 bezier-area))
286 (make-instance 'bezier-union :areas (list r1 r2)))
287
288 (defmethod region-union ((r1 bezier-union) (r2 bezier-area))
289 (let ((tr (transformation r1)))
290 (make-instance 'bezier-union
291 :areas (cons (untransform-region tr r2) (areas r1))
292 :transformation tr)))
293
294 (defmethod region-union ((r1 bezier-area) (r2 bezier-union))
295 (let ((tr (transformation r2)))
296 (make-instance 'bezier-union
297 :areas (cons (untransform-region tr r1) (areas r2))
298 :transformation tr)))
299
300 (defmethod region-union ((r1 bezier-union) (r2 bezier-union))
301 (let ((tr1 (transformation r1))
302 (tr2 (transformation r2)))
303 (if (transformation-equal tr1 tr2)
304 (make-instance 'bezier-union
305 :areas (append (areas r1) (areas r2))
306 :transformation tr1)
307 (let ((len1 (length (areas r1)))
308 (len2 (length (areas r2))))
309 (if (> len2 len1)
310 (make-instance 'bezier-union
311 :areas (append (mapcar (lambda (r) (untransform-region tr2 (transform-region tr1 r))) (areas r1)) (areas r2))
312 :transformation tr2)
313 (make-instance 'bezier-union
314 :areas (append (mapcar (lambda (r) (untransform-region tr1 (transform-region tr2 r))) (areas r2)) (areas r1))
315 :transformation tr1))))))
316
317 (defclass bezier-difference (area bezier-design)
318 ((%positive-areas :initarg :positive-areas :initform '() :reader positive-areas)
319 (%negative-areas :initarg :negative-areas :initform '() :reader negative-areas)))
320
321 (defmethod transform-region (transformation (area bezier-difference))
322 (let* ((pareas (loop for area in (positive-areas area)
323 collect (transform-region transformation area)))
324 (nareas (loop for area in (negative-areas area)
325 collect (transform-region transformation area)))
326 (result (make-instance 'bezier-difference
327 :positive-areas pareas
328 :negative-areas nareas)))
329 (when (translation-transformation-p transformation)
330 (setf (original-region result) (or (original-region area) area)))
331 result))
332
333 (defmethod bounding-rectangle* ((design bezier-difference))
334 (bounding-rectangle-of-areas (positive-areas design)))
335
336 (defmethod region-difference ((r1 bezier-area) (r2 bezier-area))
337 (make-instance 'bezier-difference
338 :positive-areas (list r1)
339 :negative-areas (list r2)))
340
341 (defmethod region-difference ((r1 bezier-area) (r2 bezier-union))
342 (let ((tr (transformation r2)))
343 (make-instance 'bezier-difference
344 :positive-areas (list r1)
345 :negative-areas (mapcar (lambda (r) (transform-region tr r)) (areas r2)))))
346
347 (defmethod region-difference ((r1 bezier-union) (r2 bezier-area))
348 (let ((tr (transformation r1)))
349 (make-instance 'bezier-difference
350 :positive-areas (mapcar (lambda (r) (transform-region tr r)) (areas r1))
351 :negative-areas (list r2))))
352
353 (defmethod region-difference ((r1 bezier-union) (r2 bezier-union))
354 (let ((tr1 (transformation r1))
355 (tr2 (transformation r2)))
356 (make-instance 'bezier-difference
357 :positive-areas (mapcar (lambda (r) (transform-region tr1 r)) (areas r1))
358 :negative-areas (mapcar (lambda (r) (transform-region tr2 r)) (areas r2)))))
359
360 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
361 ;;;
362 ;;; Converting a path to a polyline or an area to a polygon
363
364 ;;; convert a cubic bezier segment to a list of
365 ;;; line segments
366 (defun %polygonalize (p0 p1 p2 p3 &key (precision 0.01))
367 (if (< (- (+ (distance p0 p1)
368 (distance p1 p2)
369 (distance p2 p3))
370 (distance p0 p3))
371 precision)
372 (list p3)
373 (let* ((p01 (part-way p0 p1 0.5))
374 (p12 (part-way p1 p2 0.5))
375 (p23 (part-way p2 p3 0.5))
376 (p012 (part-way p01 p12 0.5))
377 (p123 (part-way p12 p23 0.5))
378 (p0123 (part-way p012 p123 0.5)))
379 (nconc (%polygonalize p0 p01 p012 p0123 :precision precision)
380 (%polygonalize p0123 p123 p23 p3 :precision precision)))))
381
382 (defgeneric polygonalize (thing))
383
384 (defmethod polygonalize ((segment bezier-segment))
385 (with-slots (p0 p1 p2 p3) segment
386 (%polygonalize p0 p1 p2 p3)))
387
388 (defmethod polygonalize ((path bezier-curve))
389 (let ((segments (%segments path)))
390 (make-polyline
391 (cons (slot-value (car segments) 'p0)
392 (mapcan #'polygonalize segments)))))
393
394 (defmethod polygonalize ((area bezier-area))
395 (let ((segments (segments area)))
396 (make-polygon (mapcan #'polygonalize segments))))
397
398 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
399 ;;;
400 ;;; Reversing a path
401
402 (defgeneric reverse-path (path))
403
404 (defun reverse-segment (bezier-segment)
405 (with-slots (p0 p1 p2 p3) bezier-segment
406 (make-bezier-segment p3 p2 p1 p0)))
407
408 (defmethod reverse-path ((path bezier-curve))
409 (make-instance 'bezier-curve
410 :segments (reverse (mapcar #'reverse-segment (%segments path)))))
411
412 (defmethod reverse-path ((path bezier-area))
413 (make-instance 'bezier-area
414 :segments (reverse (mapcar #'reverse-segment (%segments path)))
415 :transformation (transformation path)))
416
417 ;;; slanting transformation are used by Metafont
418 (defun make-slanting-transformation (slant)
419 (make-transformation 1.0 slant 0.0 1.0 0.0 0.0))
420
421 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
422 ;;;
423 ;;; Bounding rectangle
424
425 (defun evaluate-bezier (w0 w1 w2 w3 a)
426 (let ((1-a (- 1.0 a)))
427 (+ (* 1-a 1-a 1-a w0)
428 (* 3.0 1-a 1-a a w1)
429 (* 3.0 1-a a a w2)
430 (* a a a w3))))
431
432 (defun dimension-min-max (w0 w1 w2 w3)
433 (when (> w0 w3)
434 (rotatef w0 w3)
435 (rotatef w1 w2))
436 (when (and (<= w0 w1 w3)
437 (<= w0 w2 w3))
438 (return-from dimension-min-max
439 (values w0 w3)))
440 (let ((a (+ (- w0) (* 3 w1) (* -3 w2) w3))
441 (b (+ (* 2 w0) (* -4 w1) (* 2 w2)))
442 (c (- w1 w0)))
443 (if (zerop a)
444 (if (zerop b)
445 (values w0 w3)
446 (let ((candidate (/ (- c) b)))
447 (if (or (<= candidate 0.0)
448 (>= candidate 1.0))
449 (values w0 w3)
450 (let ((w (evaluate-bezier w0 w1 w2 w3 candidate)))
451 (values (min w w0) (max w w3))))))
452 (multiple-value-bind (candidate0 candidate1)
453 (solve-quadratic a b c :multiple-roots t)
454 (if (null candidate0)
455 (values w0 w3)
456 (let ((wa (evaluate-bezier w0 w1 w2 w3 candidate0))
457 (wb (evaluate-bezier w0 w1 w2 w3 candidate1)))
458 (if (or (<= candidate0 0.0) (>= candidate0 1.0))
459 (if (or (<= candidate1 0.0) (>= candidate1 1.0))
460 (values w0 w3)
461 (values (min wb w0) (max wb w3)))
462 (if (or (<= candidate1 0.0) (>= candidate1 1.0))
463 (values (min wa w0) (max wa w3))
464 (values (min wa wb w0) (max wa wb w3))))))))))
465
466 (defun segment-bounding-rectangle (segment)
467 (with-slots (p0 p1 p2 p3) segment
468 (let ((x0 (point-x p0))
469 (x1 (point-x p1))
470 (x2 (point-x p2))
471 (x3 (point-x p3))
472 (y0 (point-y p0))
473 (y1 (point-y p1))
474 (y2 (point-y p2))
475 (y3 (point-y p3)))
476 (multiple-value-bind (min-x max-x)
477 (dimension-min-max x0 x1 x2 x3)
478 (multiple-value-bind (min-y max-y)
479 (dimension-min-max y0 y1 y2 y3)
480 (values min-x min-y max-x max-y))))))
481
482 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
483 ;;;
484 ;;; Convolution
485
486 (defun find-split-points-for-side (aa bb cc)
487 (let ((roots '()))
488 (multiple-value-bind (r1 r2)
489 (solve-quadratic aa bb cc)
490 (unless (or (null r1) (<= r1 0.0) (>= r1 1.0)) (push r1 roots))
491 (unless (or (null r2) (<= r2 0.0) (>= r2 1.0)) (push r2 roots))
492 roots)))
493
494 (defun find-split-points (sides segment)
495 (let ((split-points '()))
496 (with-slots (p0 p1 p2 p3) segment
497 (let ((x0 (point-x p0)) (y0 (point-y p0))
498 (x1 (point-x p1)) (y1 (point-y p1))
499 (x2 (point-x p2)) (y2 (point-y p2))
500 (x3 (point-x p3)) (y3 (point-y p3)))
501 (let ((xa (+ (- x0) (* 3 x1) (* -3 x2) x3))
502 (ya (+ (- y0) (* 3 y1) (* -3 y2) y3))
503 (xb (* 2 (+ x0 (* -2 x1) x2)))
504 (yb (* 2 (+ y0 (* -2 y1) y2)))
505 (xc (- x1 x0))
506 (yc (- y1 y0)))
507 (loop for side in sides
508 do (let* ((sr (realpart side))
509 (si (imagpart side))
510 (aa (- (* xa si)
511 (* ya sr)))
512 (bb (- (* xb si)
513 (* yb sr)))
514 (cc (- (* xc si)
515 (* yc sr))))
516 (setf split-points
517 (append (find-split-points-for-side aa bb cc) split-points))))))
518 (sort (remove-duplicates split-points) #'<))))
519
520 (defun split-segment (segment split-points)
521 (if (null split-points)
522 (list segment)
523 (with-slots (p0 p1 p2 p3) segment
524 (let* ((n (floor (length split-points) 2))
525 (pivot (nth n split-points))
526 (left (mapcar (lambda (x) (/ x pivot))
527 (subseq split-points 0 n)))
528 (right (mapcar (lambda (x) (/ (- x pivot) (- 1.0 pivot)))
529 (subseq split-points (1+ n))))
530 (p01 (part-way p0 p1 pivot))
531 (p12 (part-way p1 p2 pivot))
532 (p23 (part-way p2 p3 pivot))
533 (p012 (part-way p01 p12 pivot))
534 (p123 (part-way p12 p23 pivot))
535 (p0123 (part-way p012 p123 pivot)))
536 (append (split-segment (make-bezier-segment p0 p01 p012 p0123) left)
537 (split-segment (make-bezier-segment p0123 p123 p23 p3) right))))))
538
539 (defun mid-derivative (p0 p1 p2 p3)
540 (setf p0 (point-to-complex p0)
541 p1 (point-to-complex p1)
542 p2 (point-to-complex p2)
543 p3 (point-to-complex p3))
544 (let ((a 0.5))
545 (+ (* a a (+ (- p0) (* 3 p1) (* -3 p2) p3))
546 (* 2 a (+ p0 (* -2 p1) p2))
547 (- p1 p0))))
548
549 (defun make-line-segment (p0 p1)
550 (make-bezier-segment p0 (part-way p0 p1 1/3) (part-way p0 p1 2/3) p1))
551
552 (defun add-points (p0 p1)
553 (make-point (+ (point-x p0) (point-x p1)) (+ (point-y p0) (point-y p1))))
554
555 (defun convert-primitive-segment-to-bezier-area (polygon segment)
556 (with-slots (p0 p1 p2 p3) segment
557 (let* ((m (mid-derivative p0 p1 p2 p3))
558 (right (reduce (lambda (a b) (if (> (dist a m) (dist b m)) a b))
559 polygon))
560 (left (reduce (lambda (a b) (if (< (dist a m) (dist b m)) a b))
561 polygon)))
562 (make-instance 'bezier-area
563 :segments
564 (list (make-bezier-segment (add-points p0 right) (add-points p1 right)
565 (add-points p2 right) (add-points p3 right))
566 (make-line-segment (add-points p3 right) (add-points p3 left))
567 (make-bezier-segment (add-points p3 left) (add-points p2 left)
568 (add-points p1 left) (add-points p0 left))
569 (make-line-segment (add-points p0 left) (add-points p0 right)))))))
570
571 (defun area-at-point (area point)
572 (let ((transformation
573 (make-translation-transformation (point-x point) (point-y point))))
574 (transform-region transformation area)))
575
576 (defun convolve-polygon-and-segment (area polygon segment first)
577 (declare (optimize debug))
578 (let* ((points (polygon-points polygon))
579 (sides (loop for (p0 p1) on (append (last points) points)
580 until (null p1)
581 collect (- (point-to-complex p1) (point-to-complex p0))))
582 (split-points (find-split-points sides segment))
583 (segments (split-segment segment split-points)))
584 (loop for segment in segments
585 if first collect (area-at-point area (slot-value segment 'p0))
586 collect (convert-primitive-segment-to-bezier-area
587 (polygon-points polygon) segment)
588 collect (area-at-point area (slot-value segment 'p3)))))
589
590 (defgeneric convolve-regions (area path))
591
592 (defmethod convolve-regions ((area bezier-area) (path bezier-curve))
593 (let ((polygon (polygonalize area)))
594 (make-instance
595 'bezier-union :areas
596 (loop for segment in (%segments path)
597 for first = t then nil
598 append (convolve-polygon-and-segment area polygon segment first)))))
599
600 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
601 ;;;
602 ;;; Rendering
603
604 (defclass scanlines ()
605 ((%first-line :initform 0 :accessor first-line)
606 (%chain :initform (make-instance 'flexichain:standard-flexichain) :reader chain)))
607
608 (defun nb-lines (lines)
609 (flexichain:nb-elements (chain lines)))
610
611 (defun crossings (lines i)
612 (flexichain:element* (chain lines) (- i (first-line lines))))
613
614 (defun line-number-to-index (lines line-number)
615 (let* ((chain (chain lines))
616 (size (flexichain:nb-elements chain)))
617 ;; make sure there is an element corresponding to the line number
618 (cond ((zerop size)
619 (flexichain:insert* chain 0 '())
620 (setf (first-line lines) line-number))
621 ((< line-number (first-line lines))
622 (loop for i from line-number below (first-line lines)
623 do (flexichain:insert* chain 0 '()))
624 (setf (first-line lines) line-number))
625 ((>= line-number (+ (first-line lines) size))
626 (loop for i from (+ (first-line lines) size) to line-number
627 do (flexichain:insert* chain size '()))))
628 (- line-number (first-line lines))))
629
630 ;;; insert a single crossing into LINES
631 (defun insert-crossing (lines line-number x inverse-p)
632 (let ((chain (chain lines))
633 (index (line-number-to-index lines line-number)))
634 (setf (flexichain:element* chain index)
635 (merge 'list
636 (flexichain:element* chain index)
637 (list (cons x inverse-p)) #'< :key #'car))))
638
639 ;;; compute the crossings of a line segment and insert
640 ;;; them into LINES
641 (defun compute-crossings (lines p0 p1)
642 (let ((inverse-p nil))
643 (when (< (point-y p1) (point-y p0))
644 (rotatef p0 p1)
645 (setf inverse-p t))
646 (let ((x0 (point-x p0)) (y0 (point-y p0))
647 (x1 (point-x p1)) (y1 (point-y p1)))
648 (loop for y from (round y0) below (round y1)
649 for x = (+ x0 (* (- x1 x0) (/ (- (+ y 0.5) y0) (- y1 y0))))
650 do (insert-crossing lines y x inverse-p)))))
651
652 (defun scan-lines (polygon)
653 (let ((lines (make-instance 'scanlines))
654 (points (polygon-points polygon)))
655 (loop for (p0 p1) on (append (last points) points)
656 until (null p1)
657 do (compute-crossings lines p0 p1))
658 lines))
659
660 (defun render-scan-lines (array pixel-value line crossings min-x min-y)
661 (let ((level 0)
662 (start nil)
663 (height (array-dimension array 0))
664 (width (array-dimension array 1)))
665 (loop for (x . inverse-p) in crossings
666 do (when (zerop level)
667 (setf start x))
668 do (setf level (if inverse-p (1+ level) (1- level)))
669 do (when (zerop level)
670 (loop for c from (round start) below (round x)
671 do (when (and (<= 0 (round (- line min-y)) (1- height))
672 (<= 0 (- c min-x) (1- width)))
673 (setf (aref array (round (- line min-y)) (- c min-x))
674 pixel-value)))))))
675
676 (defun render-polygon (array polygon pixel-value min-x min-y)
677 (let ((lines (scan-lines polygon)))
678 (loop for i from (first-line lines)
679 repeat (nb-lines lines)
680 do (render-scan-lines array pixel-value i (crossings lines i) min-x min-y))))
681
682 (defgeneric positive-negative-areas (design))
683
684 (defmethod positive-negative-areas ((design bezier-area))
685 (values (list design) '()))
686
687 (defmethod positive-negative-areas ((design bezier-union))
688 (values (areas design) '()))
689
690 (defmethod positive-negative-areas ((design bezier-difference))
691 (values (positive-areas design) (negative-areas design)))
692
693 (defun render-to-array (design)
694 (multiple-value-bind (positive-areas negative-areas)
695 (positive-negative-areas design)
696 (multiple-value-bind (min-x min-y max-x max-y)
697 (bounding-rectangle-of-areas positive-areas)
698 (setf min-x (* 4 (floor min-x))
699 min-y (* 4 (floor min-y))
700 max-x (* 4 (ceiling max-x))
701 max-y (* 4 (ceiling max-y)))
702 (let ((result (make-array (list (- max-y min-y) (- max-x min-x))
703 :element-type 'bit :initial-element 1))
704 (transformation (make-scaling-transformation* 4 4)))
705 (loop for area in positive-areas
706 do (let* ((transformed-area (transform-region transformation area))
707 (polygon (polygonalize transformed-area)))
708 (render-polygon result polygon 0 min-x min-y)))
709 (loop for area in negative-areas
710 do (let* ((transformed-area (transform-region transformation area))
711 (polygon (polygonalize transformed-area)))
712 (render-polygon result polygon 1 min-x min-y)))
713 result))))
714
715 (defparameter *pixmaps* (make-hash-table :test #'equal))
716
717 (defun resolve-ink (medium)
718 (if (eq (medium-ink medium) +foreground-ink+)
719 (medium-foreground medium)
720 (medium-ink medium)))
721
722 (defun make-ink (medium transparency)
723 (let* ((a (/ transparency 16.0))
724 (1-a (- 1.0 a)))
725 (multiple-value-bind (r g b) (color-rgb (resolve-ink medium))
726 (make-rgb-color (+ (* a 1.0) (* 1-a r))
727 (+ (* a 1.0) (* 1-a g))
728 (+ (* a 1.0) (* 1-a b))))))
729
730 (defgeneric ensure-pixmap (medium design))
731
732 (defmethod ensure-pixmap (medium rdesign)
733 (let* ((design (or (original-region rdesign) rdesign))
734 (pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design)
735 *pixmaps*)))
736 (when (null pixmap)
737 (let* ((picture (render-to-array design))
738 (height (array-dimension picture 0))
739 (width (array-dimension picture 1))
740 (reduced-picture (make-array (list (/ height 4) (/ width 4)) :initial-element 16)))
741 (loop for l from 0 below height
742 do (loop for c from 0 below width
743 do (when (zerop (aref picture l c))
744 (decf (aref reduced-picture (floor l 4) (floor c 4))))))
745 (setf pixmap
746 (with-output-to-pixmap (pixmap-medium
747 (medium-sheet medium)
748 :width (/ width 4) :height (/ height 4))
749 (loop for l from 0 below (/ height 4)
750 do (loop for c from 0 below (/ width 4)
751 do (draw-point*
752 pixmap-medium c l
753 :ink (make-ink
754 medium
755 (aref reduced-picture l c)))))))
756 (setf (gethash (list (medium-sheet medium) (resolve-ink medium) design)
757 *pixmaps*)
758 pixmap)))
759 pixmap))
760
761 (defun render-through-pixmap (design medium)
762 (multiple-value-bind (min-x min-y)
763 (bounding-rectangle* design)
764 ;; the design we've got has already been transformed by the
765 ;; medium/user transformation, and COPY-FROM-PIXMAP is in user
766 ;; coordinates. So we need to transform back (or set the medium's
767 ;; transformation to be +IDENTITY-TRANSFORMATION+ temporarily, but
768 ;; that's even uglier)
769 (multiple-value-bind (utmin-x utmin-y)
770 (untransform-position (medium-transformation medium) min-x min-y)
771 (setf min-x (floor utmin-x)
772 min-y (floor utmin-y))
773 (let ((pixmap (ensure-pixmap medium design)))
774 (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap)
775 (medium-sheet medium) min-x min-y)))))
776
777 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
778 ;;;
779 ;;; Generic drawing
780
781 (defun draw-bezier-design* (sheet design &rest options)
782 (climi::with-medium-options (sheet options)
783 (medium-draw-bezier-design* sheet design)))
784
785 (defmethod draw-design (medium (design bezier-design) &rest options &key &allow-other-keys)
786 (apply #'draw-bezier-design* medium design options))
787
788 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
789 ;;;
790 ;;; Drawing bezier designs to screen
791
792
793 ;;; Fallback method (suitable for CLX)
794
795 (defmethod medium-draw-bezier-design* (medium design)
796 (render-through-pixmap design medium))
797
798 #|
799 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
800 ;;;
801 ;;; Test cases
802
803 (defparameter *r1* (make-bezier-area* '(10 10 20 20 30 20 40 10 30 5 20 5 10 10)))
804
805 (defparameter *r2* (make-bezier-area* '(15 10 20 12 30 15 35 10 30 8 20 8 15 10)))
806
807 (defparameter *r3* (region-difference *r1* *r2*))
808
809 (defparameter *r4* (make-bezier-curve* '(100 100 120 150 160 160 170 160)))
810
811 (defparameter *r5* (convolute-regions *r2* *r4*))
812 |#

  ViewVC Help
Powered by ViewVC 1.1.5