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

Contents of /mcclim/regions.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.39 - (show annotations)
Wed Jun 3 20:33:16 2009 UTC (4 years, 10 months ago) by ahefner
Branch: MAIN
CVS Tags: HEAD
Changes since 1.38: +4 -1 lines
Handle selection-notify-events in the text gadget and input editor.
For communicating with the input editor, signal and handle a
selection-notify condition from the lower level event handler (I can't
think of a better approach to communicating across the layers). Disable
the old default of pasting by synthesizing keypress events, but make it
available via paste-as-keypress-mixin.
1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*-
2 ;;; --------------------------------------------------------------------------------------
3 ;;; Title: The CLIM Region Datatype
4 ;;; Created: 1998-12-02 19:26
5 ;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
6 ;;; License: LGPL (See file COPYING for details).
7 ;;; $Id: regions.lisp,v 1.39 2009/06/03 20:33:16 ahefner Exp $
8 ;;; --------------------------------------------------------------------------------------
9 ;;; (c) copyright 1998,1999,2001 by Gilbert Baumann
10 ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
11
12 ;;; This library is free software; you can redistribute it and/or
13 ;;; modify it under the terms of the GNU Library General Public
14 ;;; License as published by the Free Software Foundation; either
15 ;;; version 2 of the License, or (at your option) any later version.
16 ;;;
17 ;;; This library is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;;; Library General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU Library General Public
23 ;;; License along with this library; if not, write to the
24 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;;; Boston, MA 02111-1307 USA.
26
27 ;;;; Changes
28
29 ;;; When Who What
30 ;;; --------------------------------------------------------------------------------------
31 ;;; 2002-06-27 GB REGION-INTERSECTS-REGION-P has an :around method on bounding
32 ;;; rectangles.
33 ;;; 2002-06-04 APD partially fixed (BOUNDING-RECTANGLE* STANDARD-ELLIPSE)
34 ;;; 2001-07-16 GB added (REGION-CONTAINS-POSITION-P STANDARD-ELLIPSE ..)
35 ;;; added (BOUNDING-RECTANGLE* STANDARD-ELLIPSE)
36 ;;; added (REGION-INTERSECTION LINE STANDARD-ELLIPSE) and vice versa
37 ;;; 2001-07-12 GB fixed bugs in
38 ;;; (BOUNDING-RECTANGLE* STANDARD-REGION-UNION)
39 ;;; (BOUNDING-RECTANGLE* STANDARD-REGION-INTERSECTION)
40 ;;; 2001-07-09 GB maybe fixed a bug in MAP-OVER-SCHNITT-GERADE/POLYGON.
41 ;;; 2001-03-09 AR fixed a bug in MAKE-ELLIPICAL-THING
42 ;;; fixed STANDARD-ELLIPTICAL-ARC defclass
43 ;;; 2001-03-06 AR fixed bug in (REGION-EQUAL STANDARD-RECTANGLE STANDARD-RECTANGLE)
44 ;;; REGION is now a subclass of DESIGN.
45 ;;; 2001-01-21 GB fixed bug in (TRANSFORM-REGION T RECTANGLE-SET)
46 ;;; added some documentation
47
48 ;;; GB = Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
49 ;;; AR = Arnaud Rouanet <rouanet@emi.u-bordeaux.fr>
50
51 ;;; ---- TODO ----------------------------------------------------------------------------
52
53 ;; - ellipses: The intersection of two ellipses is there, but
54 ;; handling the start/end angle is not implemented.
55
56 ;; - This code is anything else than well organized.
57
58 ;; - provide better (faster) implementations for REGION-EQUAL,
59 ;; REGION-CONTAINS-REGION-P, and REGION-INTERSECTS-REGION-P.
60
61 ;; - Compute a union/intersection/difference of an union of polygon vs another
62 ;; polygon or union of polygons directly via POLYGON-OP.
63
64 ;; - STANDARD-REGION-UNION should either become a subclass
65 ;; 'STANDARD-DISJUNCT-REGION-UNION' or a flag. Some set operations could take
66 ;; advantage out the information, if the subregions of an union are disjunct.
67
68 ;; - provide sensible PRINT-OBJECT methods.
69
70 ;; - while you are are at it; provide a reasonable fast vertical scan routine.
71 ;; polygons should make use of the sweep line algorithm.
72
73 ;; - implement bounding rectangle cache for polygons and polylines
74
75 ;; - make REGION-CONTAINS-POSITION-P for polygons faster by handling the special
76 ;; case of the intersection of a horizontal line and the polygons
77
78 ;; - MAKE-POLY{LINE,GON} should canonise its arguments; no edges of length 0 and
79 ;; no co-linear vertexes. Maybe: canonise rectangles? Also a polygon of less
80 ;; than three vertexes is to be considered empty aka +nowhere+.
81
82 (in-package :clim-internals)
83
84 (defclass nowhere-region (region nowhere-mixin) ())
85 (defclass everywhere-region (region everywhere-mixin) ())
86
87 ;; coordinate is defined in coordinates.lisp
88
89 (defvar +everywhere+ (make-instance 'everywhere-region))
90 (defvar +nowhere+ (make-instance 'nowhere-region))
91
92 (defmethod bounding-rectangle* ((x nowhere-region))
93 (values 0 0 0 0))
94
95 ;; 2.5.1.1 Region Predicates in CLIM
96
97 (defgeneric region-equal (region1 region2))
98 (defgeneric region-contains-region-p (region1 region2))
99 (defgeneric region-contains-position-p (region x y))
100 (defgeneric region-intersects-region-p (region1 region2))
101
102 ;; 2.5.1.2 Composition of CLIM Regions
103
104 (defclass standard-region-union (region-set)
105 ((regions :initarg :regions :reader standard-region-set-regions)))
106
107 (defclass standard-region-intersection (region-set)
108 ((regions :initarg :regions :reader standard-region-set-regions)))
109
110 (defclass standard-region-difference (region-set)
111 ((a :initarg :a :reader standard-region-difference-a)
112 (b :initarg :b :reader standard-region-difference-b)))
113
114 ;; Protocol:
115 (defgeneric region-set-regions (region &key normalize))
116 (defgeneric map-over-region-set-regions (function region &key normalize))
117 (defgeneric region-union (region1 region2))
118 (defgeneric region-intersection (region1 region2))
119 (defgeneric region-difference (region1 region2))
120
121 ;;; ---- 2.5.2 CLIM Point Objects --------------------------------------------------------
122
123 (defclass standard-point (point)
124 ((x :type coordinate :initarg :x)
125 (y :type coordinate :initarg :y)))
126
127 (defun make-point (x y)
128 (make-instance 'standard-point :x (coerce x 'coordinate) :y (coerce y 'coordinate)))
129
130 (defmethod print-object ((self standard-point) sink)
131 (with-slots (x y) self
132 (format sink "#<~S ~S ~S>" 'standard-point x y)))
133
134 ;; Point protocol: point-position
135
136 (defgeneric point-position (point))
137
138 (defmethod point-position ((self standard-point))
139 (with-slots (x y) self
140 (values x y)))
141
142 (defmethod point-x ((self point))
143 (nth-value 0 (point-position self)))
144
145 (defmethod point-y ((self point))
146 (nth-value 1 (point-position self)))
147
148 (defmethod transform-region (transformation (self standard-point))
149 (with-slots (x y) self
150 (multiple-value-bind (x* y*) (transform-position transformation x y)
151 (make-point x* y*))))
152
153 (defmethod region-contains-position-p ((self standard-point) px py)
154 (with-slots (x y) self
155 (and (coordinate= x px) (coordinate= y py))))
156
157 ;;; ---- 2.5.3 Polygons and Polylines in CLIM --------------------------------------------
158
159 ;; Protocol:
160 (defclass standard-polyline (polyline)
161 ((points :initarg :points)
162 (closed :initarg :closed)))
163
164 (defclass standard-polygon (polygon)
165 ((points :initarg :points)) )
166
167 ;;; ---- 2.5.3.1 Constructors for CLIM Polygons and Polylines ---------------------------
168
169 (defun coord-seq->point-seq (sequence)
170 (let ((res nil))
171 (do-sequence ((x y) sequence)
172 (push (make-point x y) res))
173 (nreverse res)))
174
175 (defun make-polyline (point-seq &key closed)
176 (assert (every #'pointp point-seq))
177 (setq point-seq (coerce point-seq 'list))
178 (cond ((every (lambda (x) (region-equal x (car point-seq)))
179 (cdr point-seq))
180 +nowhere+)
181 (t
182 (make-instance 'standard-polyline :points point-seq :closed closed))))
183
184 (defun make-polyline* (coord-seq &key closed)
185 (make-polyline (coord-seq->point-seq coord-seq) :closed closed))
186
187 (defun make-polygon (point-seq)
188 (assert (every #'pointp point-seq))
189 (setq point-seq (coerce point-seq 'list))
190 (cond ((every (lambda (x) (region-equal x (car point-seq)))
191 (cdr point-seq))
192 +nowhere+)
193 (t
194 (make-instance 'standard-polygon :points point-seq))))
195
196 (defun make-polygon* (coord-seq)
197 (make-polygon (coord-seq->point-seq coord-seq)))
198
199 (defmethod polygon-points ((self standard-polygon))
200 (with-slots (points) self
201 points))
202
203 (defmethod map-over-polygon-coordinates (fun (self standard-polygon))
204 (with-slots (points) self
205 (mapc (lambda (p) (funcall fun (point-x p) (point-y p))) points)))
206
207 (defmethod map-over-polygon-segments (fun (self standard-polygon))
208 (with-slots (points) self
209 (do ((q points (cdr q)))
210 ((null (cdr q))
211 (funcall fun (point-x (car q)) (point-y (car q)) (point-x (car points)) (point-y (car points))))
212 (funcall fun (point-x (car q)) (point-y (car q)) (point-x (cadr q)) (point-y (cadr q))))))
213
214 (defmethod polygon-points ((self standard-polyline))
215 (with-slots (points) self
216 points))
217
218 (defmethod map-over-polygon-coordinates (fun (self standard-polyline))
219 (with-slots (points) self
220 (mapc (lambda (p) (funcall fun (point-x p) (point-y p))) points)))
221
222 (defmethod map-over-polygon-segments (fun (self standard-polyline))
223 (with-slots (points closed) self
224 (do ((q points (cdr q)))
225 ((null (cdr q))
226 (when closed
227 (funcall fun (point-x (car q)) (point-y (car q)) (point-x (car points)) (point-y (car points)))))
228 (funcall fun (point-x (car q)) (point-y (car q)) (point-x (cadr q)) (point-y (cadr q))))))
229
230 (defmethod polyline-closed ((self standard-polyline))
231 (with-slots (closed) self
232 closed))
233
234 (defmethod transform-region (transformation (self standard-polyline))
235 (with-slots (points closed) self
236 (make-polyline (mapcar (lambda (p)
237 (multiple-value-bind (x* y*) (transform-position transformation (point-x p) (point-y p))
238 (make-point x* y*)))
239 points)
240 :closed closed)))
241
242 (defmethod transform-region (transformation (self standard-polygon))
243 (with-slots (points) self
244 (make-polygon (mapcar (lambda (p)
245 (multiple-value-bind (x* y*) (transform-position transformation (point-x p) (point-y p))
246 (make-point x* y*)))
247 points))))
248
249 (defmethod region-contains-position-p ((self standard-polyline) x y)
250 (setf x (coerce x 'coordinate)
251 y (coerce y 'coordinate))
252 (block nil
253 (map-over-polygon-segments (lambda (x1 y1 x2 y2)
254 (when (line-contains-point-p* x1 y1 x2 y2 x y)
255 (return t)))
256 self)
257 nil))
258
259 (defun line-contains-point-p* (x1 y1 x2 y2 px py)
260 (and (or (<= x1 px x2) (>= x1 px x2))
261 (or (<= y1 py y2) (>= y1 py y2))
262 (coordinate= (* (- py y1) (- x2 x1))
263 (* (- px x1) (- y2 y1)))))
264
265 (defun line-contains-point-p** (x1 y1 x2 y2 px py)
266 (coordinate= (* (- py y1) (- x2 x1))
267 (* (- px x1) (- y2 y1))))
268
269
270 ;;; ---- 2.5.4 Lines in CLIM -------------------------------------------------------------
271
272 ;; Line protocol: line-start-point* line-end-point*
273
274 (defclass standard-line (line)
275 ((x1 :type coordinate :initarg :x1)
276 (y1 :type coordinate :initarg :y1)
277 (x2 :type coordinate :initarg :x2)
278 (y2 :type coordinate :initarg :y2)))
279
280 (defun make-line (start-point end-point)
281 (make-line* (point-x start-point) (point-y start-point) (point-x end-point) (point-y end-point)))
282
283 (defun make-line* (start-x start-y end-x end-y)
284 (setf start-x (coerce start-x 'coordinate)
285 start-y (coerce start-y 'coordinate)
286 end-x (coerce end-x 'coordinate)
287 end-y (coerce end-y 'coordinate))
288 (if (and (coordinate= start-x end-x)
289 (coordinate= start-y end-y))
290 +nowhere+
291 (make-instance 'standard-line :x1 start-x :y1 start-y :x2 end-x :y2 end-y)))
292
293 (defmethod line-start-point* ((line standard-line))
294 (with-slots (x1 y1 x2 y2) line
295 (values x1 y1)))
296
297 (defmethod line-end-point* ((line standard-line))
298 (with-slots (x1 y1 x2 y2) line
299 (values x2 y2)))
300
301 (defmethod line-start-point ((line line))
302 (multiple-value-bind (x y) (line-start-point* line)
303 (make-point x y)))
304
305 (defmethod line-end-point ((line line))
306 (multiple-value-bind (x y) (line-end-point* line)
307 (make-point x y)))
308
309 ;; polyline protocol for standard-line's:
310
311 (defmethod polygon-points ((line standard-line))
312 (with-slots (x1 y1 x2 y2) line
313 (list (make-point x1 y1) (make-point x2 y2))))
314
315 (defmethod map-over-polygon-coordinates (fun (line standard-line))
316 (with-slots (x1 y1 x2 y2) line
317 (funcall fun x1 y1)
318 (funcall fun x2 y2)))
319
320 (defmethod map-over-polygon-segments (fun (line standard-line))
321 (with-slots (x1 y1 x2 y2) line
322 (funcall fun x1 y1 x2 y2)))
323
324 (defmethod polyline-closed ((line standard-line))
325 nil)
326
327 (defmethod transform-region (transformation (line standard-line))
328 (with-slots (x1 y1 x2 y2) line
329 (multiple-value-bind (x1* y1*) (transform-position transformation x1 y1)
330 (multiple-value-bind (x2* y2*) (transform-position transformation x2 y2)
331 (make-line* x1* y1* x2* y2*)))))
332
333 (defmethod region-contains-position-p ((self standard-line) x y)
334 (multiple-value-bind (x1 y1) (line-start-point* self)
335 (multiple-value-bind (x2 y2) (line-end-point* self)
336 (line-contains-point-p* x1 y1 x2 y2 x y))))
337
338 (defmethod print-object ((self standard-line) sink)
339 (with-slots (x1 y1 x2 y2) self
340 (format sink "#<~S ~D ~D ~D ~D>" (type-of self) x1 y1 x2 y2)))
341
342 ;;; ---- 2.5.5 Rectangles in CLIM --------------------------------------------------------
343
344 ;; protocol:
345 ;; rectangle-edges*
346
347 (defclass standard-rectangle (rectangle)
348 ((coordinates :initform (make-array 4 :element-type 'coordinate))))
349
350 (defmethod initialize-instance :after ((obj standard-rectangle)
351 &key (x1 0.0d0) (y1 0.0d0)
352 (x2 0.0d0) (y2 0.0d0))
353 (let ((coords (slot-value obj 'coordinates)))
354 (setf (aref coords 0) x1)
355 (setf (aref coords 1) y1)
356 (setf (aref coords 2) x2)
357 (setf (aref coords 3) y2)))
358
359 (defmacro with-standard-rectangle ((x1 y1 x2 y2) rectangle &body body)
360 (with-gensyms (coords)
361 `(let ((,coords (slot-value ,rectangle 'coordinates)))
362 (declare (type (simple-array coordinate (4)) ,coords))
363 (let ((,x1 (aref ,coords 0))
364 (,y1 (aref ,coords 1))
365 (,x2 (aref ,coords 2))
366 (,y2 (aref ,coords 3)))
367 (declare (type coordinate ,x1 ,y1 ,x2 ,y2))
368 ,@body))))
369
370 (defmacro with-standard-rectangle* ((&key x1 y1 x2 y2) rectangle &body body)
371 (with-gensyms (coords)
372 `(let ((,coords (slot-value ,rectangle 'coordinates)))
373 (declare (type (simple-array coordinate (4)) ,coords))
374 (let (,@(and x1 `((,x1 (aref ,coords 0))))
375 ,@(and y1 `((,y1 (aref ,coords 1))))
376 ,@(and x2 `((,x2 (aref ,coords 2))))
377 ,@(and y2 `((,y2 (aref ,coords 3)))))
378 (declare (type coordinate
379 ,@(and x1 `(,x1))
380 ,@(and y1 `(,y1))
381 ,@(and x2 `(,x2))
382 ,@(and y2 `(,y2))))
383 ,@body))))
384
385 (defun make-rectangle (point1 point2)
386 (make-rectangle* (point-x point1) (point-y point1) (point-x point2) (point-y point2)))
387
388 (defun make-rectangle* (x1 y1 x2 y2)
389 (psetq x1 (coerce (min x1 x2) 'coordinate)
390 x2 (coerce (max x1 x2) 'coordinate)
391 y1 (coerce (min y1 y2) 'coordinate)
392 y2 (coerce (max y1 y2) 'coordinate))
393 (if (or (coordinate= x1 x2)
394 (coordinate= y1 y2))
395 +nowhere+
396 (make-instance 'standard-rectangle :x1 x1 :x2 x2 :y1 y1 :y2 y2)))
397
398 (defmethod rectangle-edges* ((rect standard-rectangle))
399 (with-standard-rectangle (x1 y1 x2 y2)
400 rect
401 (values x1 y1 x2 y2)))
402
403 ;;; standard-rectangles are immutable and all that, but we still need to set
404 ;;; their positions and dimensions (in output recording)
405 (defgeneric* (setf rectangle-edges*) (x1 y1 x2 y2 rectangle))
406
407 (defmethod* (setf rectangle-edges*)
408 (x1 y1 x2 y2 (rectangle standard-rectangle))
409 (let ((coords (slot-value rectangle 'coordinates)))
410 (declare (type (simple-array coordinate (4)) coords))
411 (setf (aref coords 0) x1)
412 (setf (aref coords 1) y1)
413 (setf (aref coords 2) x2)
414 (setf (aref coords 3) y2))
415 (values x1 y1 x2 y2))
416
417 (defmethod rectangle-min-point ((rect rectangle))
418 (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect)
419 (declare (ignore x2 y2))
420 (make-point x1 y1)))
421
422 (defmethod rectangle-min-point ((rect standard-rectangle))
423 (with-standard-rectangle* (:x1 x1 :y1 y1)
424 rect
425 (make-point x1 y1)))
426
427 (defmethod rectangle-max-point ((rect rectangle))
428 (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect)
429 (declare (ignore x1 y1))
430 (make-point x2 y2)))
431
432 (defmethod rectangle-max-point ((rect standard-rectangle))
433 (with-standard-rectangle* (:x2 x2 :y2 y2)
434 rect
435 (make-point x2 y2)))
436
437 (defmethod rectangle-min-x ((rect rectangle))
438 (nth-value 0 (rectangle-edges* rect)))
439
440 (defmethod rectangle-min-x ((rect standard-rectangle))
441 (with-standard-rectangle* (:x1 x1)
442 rect
443 x1))
444
445 (defmethod rectangle-min-y ((rect rectangle))
446 (nth-value 1 (rectangle-edges* rect)))
447
448 (defmethod rectangle-min-y ((rect standard-rectangle))
449 (with-standard-rectangle* (:y1 y1)
450 rect
451 y1))
452
453
454 (defmethod rectangle-max-x ((rect rectangle))
455 (nth-value 2 (rectangle-edges* rect)))
456
457 (defmethod rectangle-max-x ((rect standard-rectangle))
458 (with-standard-rectangle* (:x2 x2)
459 rect
460 x2))
461
462 (defmethod rectangle-max-y ((rect rectangle))
463 (nth-value 3 (rectangle-edges* rect)))
464
465 (defmethod rectangle-max-y ((rect standard-rectangle))
466 (with-standard-rectangle* (:y2 y2)
467 rect
468 y2))
469
470 (defmethod rectangle-width ((rect rectangle))
471 (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect)
472 (declare (ignore y1 y2))
473 (- x2 x1)))
474
475 (defmethod rectangle-width ((rect standard-rectangle))
476 (with-standard-rectangle* (:x1 x1 :x2 x2)
477 rect
478 (- x2 x1)))
479
480 (defmethod rectangle-height ((rect rectangle))
481 (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect)
482 (declare (ignore x1 x2))
483 (- y2 y1)))
484
485 (defmethod rectangle-height ((rect standard-rectangle))
486 (with-standard-rectangle* (:y1 y1 :y2 y2)
487 rect
488 (- y2 y1)))
489
490 (defmethod rectangle-size ((rect rectangle))
491 (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect)
492 (values (- x2 x1) (- y2 y1))))
493
494 (defmethod rectangle-size ((rect standard-rectangle))
495 (with-standard-rectangle (x1 y1 x2 y2)
496 rect
497 (values (- x2 x1) (- y2 y1))))
498
499 ;; polyline/polygon protocol for standard-rectangle's
500
501 (defmethod polygon-points ((rect standard-rectangle))
502 (with-standard-rectangle (x1 y1 x2 y2)
503 rect
504 (list (make-point x1 y1)
505 (make-point x1 y2)
506 (make-point x2 y2)
507 (make-point x2 y1))))
508
509
510 (defmethod map-over-polygon-coordinates (fun (rect standard-rectangle))
511 (with-standard-rectangle (x1 y1 x2 y2)
512 rect
513 (funcall fun x1 y1)
514 (funcall fun x1 y2)
515 (funcall fun x2 y2)
516 (funcall fun x2 y1)))
517
518 (defmethod map-over-polygon-segments (fun (rect standard-rectangle))
519 (with-standard-rectangle (x1 y1 x2 y2)
520 rect
521 (funcall fun x1 y1 x1 y2)
522 (funcall fun x1 y2 x2 y2)
523 (funcall fun x2 y2 x2 y1)
524 (funcall fun x2 y1 x1 y1)))
525
526 (defmethod transform-region (transformation (rect standard-rectangle))
527 (cond ((rectilinear-transformation-p transformation)
528 (with-standard-rectangle (x1 y1 x2 y2)
529 rect
530 (multiple-value-bind (x1* y1*) (transform-position transformation x1 y1)
531 (multiple-value-bind (x2* y2*) (transform-position transformation x2 y2)
532 (make-rectangle* x1* y1* x2* y2*)))))
533 (t
534 (make-polygon (mapcar (lambda (p) (transform-region transformation p))
535 (polygon-points rect)))) ))
536
537 (defmethod region-contains-position-p ((self standard-rectangle) x y)
538 (with-standard-rectangle (x1 y1 x2 y2)
539 self
540 (and (<= x1 (coerce x 'coordinate) x2)
541 (<= y1 (coerce y 'coordinate) y2))))
542
543 ;;; ---- 2.5.6 Ellipses and Elliptical Arcs in CLIM --------------------------------------
544
545 (defclass elliptical-thing ()
546 ((start-angle :initarg :start-angle)
547 (end-angle :initarg :end-angle)
548 (tr :initarg :tr))) ;a transformation from the unit circle to get the elliptical object
549
550 (defmethod print-object ((ell elliptical-thing) stream)
551 (with-slots (start-angle end-angle tr) ell
552 (format stream "#<~A [~A ~A] ~A>"
553 (type-of ell)
554 (and start-angle (* (/ 180 pi) start-angle))
555 (and end-angle (* (/ 180 pi) end-angle))
556 tr)))
557
558 (defclass standard-ellipse (elliptical-thing ellipse) ())
559 (defclass standard-elliptical-arc (elliptical-thing elliptical-arc) ())
560
561 ;;; ---- 2.5.6.1 Constructor Functions for Ellipses and Elliptical Arcs in CLIM ---------
562
563 (defun make-ellipse (center-point radius-1-dx radius-1-dy radius-2-dx radius-2-dy &key start-angle end-angle)
564 (make-ellipse* (point-x center-point) (point-y center-point)
565 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
566 :start-angle start-angle
567 :end-angle end-angle))
568
569 (defun make-ellipse* (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy
570 &key start-angle end-angle)
571 (make-ellipical-thing 'standard-ellipse
572 center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy
573 start-angle end-angle))
574
575 (defun make-elliptical-arc (center-point radius-1-dx radius-1-dy radius-2-dx radius-2-dy &key start-angle end-angle)
576 (make-elliptical-arc* (point-x center-point) (point-y center-point)
577 radius-1-dx radius-1-dy radius-2-dx radius-2-dy
578 :start-angle start-angle
579 :end-angle end-angle))
580
581 (defun make-elliptical-arc* (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy
582 &key start-angle end-angle)
583 (make-ellipical-thing 'standard-elliptical-arc
584 center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy
585 start-angle end-angle))
586
587 (defun make-ellipical-thing (class
588 center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy
589 start-angle end-angle)
590 (setf center-x (coerce center-x 'coordinate)
591 center-y (coerce center-y 'coordinate)
592 radius-1-dx (coerce radius-1-dx 'coordinate)
593 radius-1-dy (coerce radius-1-dy 'coordinate)
594 radius-2-dx (coerce radius-2-dx 'coordinate)
595 radius-2-dy (coerce radius-2-dy 'coordinate)
596 start-angle (and start-angle (coerce start-angle 'coordinate))
597 end-angle (and end-angle (coerce end-angle 'coordinate)) )
598
599 (let ((tr (make-3-point-transformation* 0 0 1 0 0 1
600 center-x center-y
601 (+ center-x radius-1-dx) (+ center-y radius-1-dy)
602 (+ center-x radius-2-dx) (+ center-y radius-2-dy))))
603 (cond ((and (null start-angle) (null end-angle)))
604 ((null start-angle) (setf start-angle 0))
605 ((null end-angle) (setf end-angle (* 2 pi))))
606 (make-instance class :tr tr :start-angle start-angle :end-angle end-angle) ))
607
608 (defmethod transform-region (transformation (self elliptical-thing))
609 (with-slots (start-angle end-angle tr) self
610 ;; I think this should be untransform-angle below, as the ellipse angles
611 ;; go counter-clockwise in screen coordinates, whereas our transformations
612 ;; rotate clockwise.. -Hefner
613 (let ((start-angle* (and start-angle (untransform-angle transformation start-angle)))
614 (end-angle* (and end-angle (untransform-angle transformation end-angle))))
615 (when (reflection-transformation-p transformation)
616 (rotatef start-angle* end-angle*))
617 (make-instance (type-of self)
618 :tr (compose-transformations transformation tr)
619 :start-angle start-angle*
620 :end-angle end-angle*))))
621
622 (defmethod region-contains-position-p ((self standard-ellipse) x y)
623 ;; XXX start/end angle still missing
624 (with-slots (tr) self
625 (multiple-value-bind (x y) (untransform-position tr x y)
626 (<= (+ (* x x) (* y y)) 1))))
627
628 (defmethod bounding-rectangle* ((region standard-ellipse))
629 ;; XXX start/end angle still missing
630 (with-slots (tr) region
631 (flet ((contact-radius* (x y)
632 "Returns coordinates of the radius of the point, in
633 which the vector field (x y) touches the ellipse."
634 (multiple-value-bind (xc yc) (untransform-distance tr x y)
635 (let* ((d (sqrt (+ (* xc xc) (* yc yc))))
636 (xn (- (/ yc d)))
637 (yn (/ xc d)))
638 (transform-distance tr xn yn)))))
639 (multiple-value-bind (cx cy) (ellipse-center-point* region)
640 (if (zerop (ellipse-radii region))
641 (values cx cy cx cy)
642 (multiple-value-bind (vdx vdy) (contact-radius* 1 0)
643 (declare (ignore vdx))
644 (multiple-value-bind (hdx hdy) (contact-radius* 0 1)
645 (declare (ignore hdy))
646 (let ((rx (abs hdx))
647 (ry (abs vdy)))
648 (values (- cx rx) (- cy ry)
649 (+ cx rx) (+ cy ry))))))))))
650
651 (defun intersection-line/unit-circle (x1 y1 x2 y2)
652 "Computes the intersection of the line from (x1,y1) to (x2,y2) and the unit circle.
653 If the intersection is empty, NIL is returned.
654 Otherwise four values are returned: x1, y1, x2, y2; the start and end point of the
655 resulting line."
656 (let* ((dx (- x2 x1))
657 (dy (- y2 y1))
658 (a (+ (expt dx 2) (expt dy 2)))
659 (b (+ (* 2 x1 dx) (* 2 y1 dy)))
660 (c (+ (expt x1 2) (expt y1 2) -1)))
661 (let ((s1 (- (/ (+ (sqrt (- (expt b 2) (* 4 a c))) b) (* 2 a))))
662 (s2 (- (/ (- b (sqrt (- (expt b 2) (* 4 a c)))) (* 2 a)))))
663 (cond ((and (realp s1) (realp s2)
664 (not (and (< s1 0) (< s2 0)))
665 (not (and (> s1 1) (> s2 1))))
666 (let ((s1 (max 0 (min 1 s1)))
667 (s2 (max 0 (min 1 s2))))
668 (values (+ x1 (* s1 dx))
669 (+ y1 (* s1 dy))
670 (+ x1 (* s2 dx))
671 (+ y1 (* s2 dy)))))
672 (t
673 nil)))))
674
675 (defmethod region-intersection ((line line) (ellipse standard-ellipse))
676 (with-slots (tr) ellipse
677 (multiple-value-bind (x1 y1 x2 y2)
678 (multiple-value-call #'intersection-line/unit-circle
679 (multiple-value-call #'untransform-position tr (line-start-point* line))
680 (multiple-value-call #'untransform-position tr (line-end-point* line)))
681 (if x1
682 (multiple-value-call #'make-line*
683 (transform-position tr x1 y1)
684 (transform-position tr x2 y2))
685 +nowhere+))))
686
687 (defmethod region-intersection ((ellipse standard-ellipse) (line standard-line))
688 (region-intersection ellipse line))
689
690 ;;; ---- 2.5.6.2 Accessors for CLIM Elliptical Objects -----------------------------------
691
692 (defmethod ellipse-center-point* ((self elliptical-thing))
693 (with-slots (tr) self
694 (transform-position tr 0 0)))
695
696 (defmethod ellipse-center-point ((self elliptical-thing))
697 (with-slots (tr) self
698 (transform-region tr (make-point 0 0))))
699
700 (defmethod ellipse-radii ((self elliptical-thing))
701 (with-slots (tr) self
702 (multiple-value-bind (dx1 dy1) (transform-distance tr 1 0)
703 (multiple-value-bind (dx2 dy2) (transform-distance tr 0 1)
704 (values dx1 dy1 dx2 dy2)))))
705
706 (defmethod ellipse-start-angle ((self elliptical-thing))
707 (with-slots (start-angle) self
708 start-angle))
709
710 (defmethod ellipse-end-angle ((self elliptical-thing))
711 (with-slots (end-angle) self
712 end-angle))
713
714
715
716 (defun ellipse-coefficients (ell)
717 ;; Returns the coefficients of the equation specifing the ellipse as in
718 ;; ax^2 + by^2 + cxy + dx + dy - f = 0
719
720 ;; Note 1:
721 ;; The `f' here may seem to be superfluous, since you
722 ;; could simply multiply the whole equation by 1/f. But this is
723 ;; not the case, since `f' may as well be 0.
724
725 ;; Note 2:
726 ;; In the literature you often find something like
727 ;; (x^2)/a + (y^2)/b - 1 = 0 for an axis aligned ellipse, but
728 ;; I rather choose to treat all coefficients as simple factors instead
729 ;; of denominators.
730
731 (with-slots (tr) ell
732 ;;warum die inverse hier?
733 (multiple-value-bind (a b d e c f) (get-transformation (invert-transformation tr))
734 (values
735 (+ (* a a) (* d d)) ; x**2
736 (+ (* b b) (* e e)) ; y**2
737 (+ (* 2 a b) (* 2 d e)) ; xy
738 (+ (* 2 a c) (* 2 d f)) ; x
739 (+ (* 2 b c) (* 2 e f)) ; y
740 (+ (* c c) (* f f) -1)))) )
741
742 ;;; Straight from the horse's mouth -- moore
743 ;;;
744 ;;; Axis of an ellipse
745 ;;; -------------------------
746
747 ;; Given an ellipse with its center at the origin, as
748
749 ;; ax^2 + by^2 + cxy - 1 = 0
750
751 ;; The two axis of an ellipse are characterized by minimizing and
752 ;; maximizing the radius. Let (x,y) be a point on the delimiter of the
753 ;; ellipse. It's radius (distance from the origin) then is:
754
755 ;; r^2 = x^2 + y^2
756
757 ;; To find the axis can now be stated as an minimization problem with
758 ;; constraints. So mechanically construct the auxiliarry function H:
759
760 ;; H = x^2 + y^2 - k(ax^2 + by^2 + cxy - 1)
761
762 ;; So the following set of equations remain to be solved
763
764 ;; (I) dH/dx = 0 = 2x + 2kax + kcy
765 ;; (II) dH/dy = 0 = 2y + 2kby + kcx
766 ;; (III) dH/dk = 0 = ax^2 + by^2 + cxy - 1
767
768 ;; Unfortunately, as I always do the math work - hopelessly, even -
769 ;; Maxima is the tool of my choice:
770
771 ;; g1: 2*x + 2*k*a*x + k*c*y$
772 ;; g2: 2*y + 2*k*b*y + k*c*x$
773 ;; g3: a*x*x + b*y*y + c*x*y -1$
774
775 ;; sol1: solve ([g1,g2],[k,y])$
776
777 ;; /* This yields two solutions because of the squares with occur. The
778 ;; * last equation (G3) must therefore be handled for both solutions for
779 ;; * y.
780 ;; */
781
782 ;; y1: rhs(first(rest(first(sol1))))$
783 ;; y2: rhs(first(rest(first(rest(sol1)))))$
784
785 ;; /* Substitute the 'y' found. */
786 ;; sol2: solve(subst(y1,y,g3),x);
787 ;; x11: rhs(first(sol2));
788 ;; x12: rhs(first(rest(sol2)));
789
790 ;; sol3: solve(subst(y2,y,g3),x);
791 ;; x21: rhs(first(sol3));
792 ;; x22: rhs(first(rest(sol3)));
793
794 ;; /* dump everything */
795 ;; dumpsol([[x=x11,y=y1], [x=x12,y=y1], [x=x21,y=y2], [x=x22,y=y2]]);
796
797 (defun ellipse-normal-radii* (ell)
798 (multiple-value-bind (a b c) (ellipse-coefficients ell)
799 (cond ((coordinate= 0 c)
800 ;; this is the unit circle
801 (values 0 (sqrt (/ 1 b))
802 (sqrt (/ 1 a)) 0))
803 (t
804 (let* ((x1 (- (/ c
805 (sqrt (+ (- (* (* c c)
806 (sqrt (+ (* c c)
807 (* b b)
808 (- (* 2 a b)) (* a a)))))
809 (- (* 2 (* b b)
810 (sqrt (+ (* c c) (* b b)
811 (- (* 2 a b)) (* a a)))))
812 (* 2 a b (sqrt (+ (* c c) (* b b)
813 (- (* 2 a b))
814 (* a a))))
815 (* 2 b (* c c))
816 (* 2 (expt b 3))
817 (- (* 4 a (* b b))) (* 2 (* a a) b))))))
818 (y1 (- (/ (+ (* (sqrt (+ (* c c)
819 (* b b)
820 (- (* 2 a b))
821 (* a a)))
822 x1)
823 (- (* b x1)) (* a x1))
824 c)))
825 (x2 (- (/ c
826 (sqrt (+ (* (* c c)
827 (sqrt (+ (* c c)
828 (* b b)
829 (- (* 2 a b))
830 (* a a))))
831 (* 2 (* b b) (sqrt (+ (* c c)
832 (* b b)
833 (- (* 2 a b))
834 (* a a))))
835 (- (* 2 a b (sqrt (+ (* c c)
836 (* b b)
837 (- (* 2 a b))
838 (* a a)))))
839 (* 2 b (* c c))
840 (* 2 (expt b 3))
841 (- (* 4 a (* b b))) (* 2 (* a a) b))))))
842 (y2 (- (/ (+ (- (* (sqrt (+ (* c c)
843 (* b b)
844 (- (* 2 a b))
845 (* a a)))
846 x2))
847 (- (* b x2)) (* a x2))
848 c))))
849 (values x1 y1 x2 y2))))))
850
851 ;;; ---- Intersection of Ellipse vs. Ellipse ---------------------------------------------
852
853 ;; Das ganze ist so unverstaendlich, ich muss noch mal nach meinen Notizen
854 ;; fanden, um die Herleitung der Loesung fuer das Schnittproblem praesentieren
855 ;; zu koennen.
856
857 (defun intersection-ellipse/ellipse (e1 e2)
858 ;; Eine der beiden Ellipsen fuehren wir zuerst auf den Einheitskreis zurueck.
859 (let ((a (invert-transformation (slot-value e1 'tr))))
860 (let ((r (intersection-ellipse/unit-circle (transform-region a e2))))
861 (if (atom r)
862 r
863 (mapcar (lambda (p)
864 (multiple-value-bind (x y) (transform-position (slot-value e1 'tr) (car p) (cdr p))
865 (make-point x y)))
866 r)))))
867
868 (defun intersection-ellipse/unit-circle (ell)
869 (multiple-value-bind (a b c d e f) (ellipse-coefficients ell)
870 (let ((pn (elli-polynom ell)))
871 (cond ((= (length pn) 0)
872 :coincident)
873 (t
874 (let ((ys (newton-iteration pn 0d0))
875 (res nil))
876 (dolist (y ys)
877 (let ((x (sqrt (- 1 (* y y)))))
878 (when (realp x)
879 (when (coordinate= 0 (ellipse-equation a b c d e f x y))
880 (pushnew (cons x y) res :test #'equal))
881 (when (coordinate= 0 (ellipse-equation a b c d e f (- x) y))
882 (pushnew (cons (- x) y) res :test #'equal)) )))
883 res)) ))))
884
885 (defun ellipse-equation (a b c d e f x y)
886 (+ (* a x x) (* b y y) (* c x y) (* d x) (* e y) f))
887
888 (defun elli-polynom (ell)
889 ;; Was ganz lustig ist, ist dass wir bei Kreisen immer ein Polynom
890 ;; vom Grade zwei bekommen.
891 (multiple-value-bind (a b c d e f) (ellipse-coefficients ell)
892 (canonize-polynom
893 (vector (+ (* (- b a) (- b a)) (* c c))
894 (+ (* 2 b e) (* -2 a e) (* 2 c d))
895 (+ (* e e) (* 2 (- b a) (+ a f)) (* -1 c c) (* d d))
896 (+ (* 2 e a) (* 2 e f) (* -2 c d))
897 (+ (* (+ a f) (+ a f)) (* -1 d d)) ))) )
898
899 ;; Wir basteln uns mal eine einfache Newtoniteration. Manchmal
900 ;; scheitern wir noch hoffungslos an lokalen Minima. Ansonsten ist das
901 ;; Konvergenzverhalten fuer unsere Aufgabe schon ganz gut. Aber wir
902 ;; handeln uns durch das Abdividieren der Nullstellen z.T. noch
903 ;; beachtliche Fehler ein; ich versuche das zu mildern in dem ich nach
904 ;; Finden einer Nullstell noch eine paar Newtonschritte mit dem
905 ;; Original-Polynom mache (newton-ziel-gerade).
906
907 ;; Ich sollte man nicht so faul sein und die reichhaltige Literatur zu
908 ;; Rate ziehen tun; es muss auch etwas bessers als Newtoniteration
909 ;; geben. Ich habe da noch so vage Erinnerungen an die
910 ;; Numerik-Vorlesung ...
911
912 (defun newton-ziel-gerade (pn x &optional (n 4))
913 (cond ((= n 0) x)
914 ((multiple-value-bind (f p2) (horner-schema pn x)
915 (multiple-value-bind (f*) (horner-schema p2 x)
916 (newton-ziel-gerade pn (- x (/ f f*)) (- n 1)))))))
917
918 (defun solve-p1 (b c)
919 (if (= b 0)
920 nil
921 (list (- (/ c b)))))
922
923 (defun solve-p2 (a b c)
924 (cond ((= a 0)
925 (solve-p1 b c))
926 (t
927 (let* ((p (/ b a))
928 (q (/ c a))
929 (d (- (/ (* p p) 4) q)))
930 (cond ((< d 0)
931 nil)
932 ((= d 0)
933 (list (/ p 2)))
934 (t
935 (list (+ (/ p 2) (sqrt d))
936 (- (/ p 2) (sqrt d))))))) ))
937
938 (defun maybe-solve-polynom-trivially (pn)
939 (case (length pn)
940 (0 (values nil t))
941 (1 (values nil t))
942 (2 (values (solve-p1 (aref pn 0) (aref pn 1)) t))
943 (3 (values (solve-p2 (aref pn 0) (aref pn 1) (aref pn 2)) t))
944 (t (values nil nil))))
945
946 (defun canonize-polynom (pn)
947 (cond ((= (length pn) 0) pn)
948 ((coordinate= (aref pn 0) 0)
949 (canonize-polynom (subseq pn 1)))
950 (t pn)))
951
952 (defun newton-iteration (polynom x-start)
953 ;; ACHTUNG: Speziell auf unser problem angepasst, nicht ohne lesen uebernehmen!
954 (multiple-value-bind (sol done?) (maybe-solve-polynom-trivially polynom)
955 (cond (done?
956 sol)
957 (t
958 (let ((x x-start)
959 x1
960 (n 0)
961 (pn polynom)
962 (eps-f 0d0)
963 (eps-f* 0d-16)
964 (eps-x 1d-20)
965 (m 20) ;maximal zahl schritte
966 (res nil) )
967 (loop
968 (cond ((> n m)
969 (return)))
970 (multiple-value-bind (f p2) (horner-schema pn x)
971 (multiple-value-bind (f*) (horner-schema p2 x)
972 (cond ((<= (abs f*) eps-f*)
973 ;; Wir haengen an einer Extremstelle fest -- mit zufaelligem Startwert weiter.
974 (setf x1 (+ 1d0 (random 2d0))))
975 (t
976 (setf x1 (- x (/ f f*)))
977 (cond ((or (<= (abs f) eps-f)
978 (<= (abs (- x1 x)) eps-x))
979 ;; noch ein paar newton schritte, um das ergebnis zu verbessern
980 (setf x1 (newton-ziel-gerade polynom x1))
981 (push x1 res)
982 ;; abdividieren
983 (multiple-value-bind (f p2) (horner-schema pn x1)
984 f
985 (setq pn (canonize-polynom p2))
986 (multiple-value-bind (sol done?) (maybe-solve-polynom-trivially pn)
987 (when done?
988 ;; Hier trotzdem noch nachiterieren -- ist das eine gute Idee?
989 (setf sol (mapcar (lambda (x) (newton-ziel-gerade polynom x)) sol))
990 (setf res (nconc sol res))
991 (return))))
992 (setf x1 x-start)
993 (setq n 0)) ))))
994 (setf x (min 1d0 (max -1d0 x1))) ;Darf man das machen?
995 (incf n)))
996 res)) )))
997
998 (defun horner-schema (polynom x)
999 ;; Wertet das polynom `polynom' mit Hilfe des Hornerschemas an der
1000 ;; Stelle `x' aus; Gibt zwei Werte zurueck:
1001 ;; - den Funktionswert
1002 ;; - die letzte Zeile des Hornerschemas (Divisionsergebnis)
1003 (let ((n (length polynom)))
1004 (cond ((= n 0) (values 0))
1005 ((= n 1) (values (aref polynom 0) '#()))
1006 (t
1007 (let ((b (make-array (1- n))))
1008 (setf (aref b 0) (aref polynom 0))
1009 (do ((i 1 (+ i 1)))
1010 ((= i (- n 1))
1011 (values
1012 (+ (* (aref b (- i 1)) x) (aref polynom i))
1013 b))
1014 (setf (aref b i) (+ (* (aref b (- i 1)) x) (aref polynom i))))))) ))
1015
1016
1017
1018 ;;;; ====================================================================================================
1019
1020 (defmethod region-union ((a point) (b point))
1021 (cond ((region-equal a b)
1022 a)
1023 (t
1024 (make-instance 'standard-region-union :regions (list a b)))))
1025
1026 (defmethod region-intersection ((a point) (b point))
1027 (cond
1028 ((region-equal a b) a)
1029 (t +nowhere+)))
1030
1031 (defmethod region-equal ((a point) (b point))
1032 (and (coordinate= (point-x a) (point-x b))
1033 (coordinate= (point-y a) (point-y b))))
1034
1035
1036 ;;; ====================================================================================================
1037
1038 ;;; ---- Rectangle Sets ---------------------------------------------------------------------------------
1039
1040 (defclass standard-rectangle-set (region-set bounding-rectangle)
1041 ((bands
1042 ;; Represents the set of rectangles. This is list like:
1043 ;;
1044 ;; ((<y_1> . <x_band_1>)
1045 ;; (<y_2> . <x_band_2>)
1046 ;; :
1047 ;; (<y_n>))
1048 ;;
1049 ;; <x_band_i> := (x_i_1 u_i_1 x_i_2 u_i_2 ... x_i_m u_i_m)
1050 ;;
1051 ;; Now a point (x,y) is member of the rectangle set, if there is an
1052 ;; i, such that y member of [y_i, y_(i+1)] and x member of x_band_i.
1053 ;;
1054 ;; An x is member of an band i, if there is an j, such that x
1055 ;; member [x_i_j, u_i_j].
1056 ;;
1057 ;; That is <x_band_i> describes the possible x-coordinates in the
1058 ;; y-range [y_i, y_(i+1)].
1059 ;;
1060 :initarg :bands
1061 :reader standard-rectangle-set-bands)
1062 ;;
1063 (bounding-rectangle
1064 ;; Caches the regions bounding-rectangle. Is either NIL or the
1065 ;; bounding-rectangle, represented by a list (x1 y1 x2 y2).
1066 :initform nil)))
1067
1068 (defmethod map-over-region-set-regions (fun (self standard-rectangle-set) &key normalize)
1069 (with-slots (bands) self
1070 (cond ((or (null normalize) (eql normalize :x-banding))
1071 (map-over-bands-rectangles (lambda (x1 y1 x2 y2)
1072 (funcall fun (make-rectangle* x1 y1 x2 y2)))
1073 bands))
1074 ((eql normalize :y-banding)
1075 (map-over-bands-rectangles (lambda (y1 x1 y2 x2)
1076 (funcall fun (make-rectangle* x1 y1 x2 y2)))
1077 (xy-bands->yx-bands bands)))
1078 (t
1079 (error "Bad ~S argument to ~S: ~S"
1080 :normalize 'map-over-region-set-regions normalize)) )))
1081
1082 (defmethod region-set-regions ((self standard-rectangle-set) &key normalize)
1083 (let ((res nil))
1084 (map-over-region-set-regions (lambda (r) (push r res)) self :normalize normalize)
1085 res))
1086
1087 (defun make-standard-rectangle-set (bands)
1088 (cond ((null bands) +nowhere+)
1089 ((and (= (length bands) 2)
1090 (null (cdr (second bands)))
1091 (= (length (cdr (first bands))) 2))
1092 (make-rectangle* (first (cdar bands)) (caar bands)
1093 (second (cdar bands)) (caadr bands)))
1094 ((= (length (first bands)) 1)
1095 (make-standard-rectangle-set (rest bands)))
1096 (t
1097 (make-instance 'standard-rectangle-set :bands bands)) ))
1098
1099 ;;; rectangle-set vs. rectangle-set
1100
1101 (defmethod region-union ((xs standard-rectangle-set) (ys standard-rectangle-set))
1102 (make-standard-rectangle-set (bands-union (standard-rectangle-set-bands xs)
1103 (standard-rectangle-set-bands ys))))
1104
1105 (defmethod region-intersection ((xs standard-rectangle-set) (ys standard-rectangle-set))
1106 (make-standard-rectangle-set (bands-intersection (standard-rectangle-set-bands xs)
1107 (standard-rectangle-set-bands ys))))
1108
1109 (defmethod region-difference ((xs standard-rectangle-set) (ys standard-rectangle-set))
1110 (make-standard-rectangle-set (bands-difference (standard-rectangle-set-bands xs)
1111 (standard-rectangle-set-bands ys))))
1112
1113 ;;; rectangle-set vs. rectangle and vice versa
1114
1115 (defmethod region-union ((xs standard-rectangle-set) (ys standard-rectangle))
1116 (region-union xs (rectangle->standard-rectangle-set ys)))
1117
1118 (defmethod region-union ((xs standard-rectangle) (ys standard-rectangle-set))
1119 (region-union (rectangle->standard-rectangle-set xs) ys))
1120
1121 (defmethod region-difference ((xs standard-rectangle-set) (ys standard-rectangle))
1122 (region-difference xs (rectangle->standard-rectangle-set ys)))
1123
1124 (defmethod region-difference ((xs standard-rectangle) (ys standard-rectangle-set))
1125 (region-difference (rectangle->standard-rectangle-set xs) ys))
1126
1127 (defmethod region-intersection ((xs standard-rectangle-set) (ys standard-rectangle))
1128 (region-intersection xs (rectangle->standard-rectangle-set ys)))
1129
1130 (defmethod region-intersection ((xs standard-rectangle) (ys standard-rectangle-set))
1131 (region-intersection (rectangle->standard-rectangle-set xs) ys))
1132
1133 ;;; rectangle vs rectangle
1134
1135 (defmethod region-union ((xs standard-rectangle) (ys standard-rectangle))
1136 (region-union (rectangle->standard-rectangle-set xs) (rectangle->standard-rectangle-set ys)))
1137
1138 (defmethod region-difference ((xs standard-rectangle) (ys standard-rectangle))
1139 (region-difference (rectangle->standard-rectangle-set xs) (rectangle->standard-rectangle-set ys)))
1140
1141 (defmethod region-intersection ((xs standard-rectangle) (ys standard-rectangle))
1142 (region-intersection (rectangle->standard-rectangle-set xs) (rectangle->standard-rectangle-set ys)))
1143
1144 (defmethod region-intersection ((xr rectangle) (yr rectangle))
1145 (region-intersection (rectangle->standard-rectangle-set xr)
1146 (rectangle->standard-rectangle-set yr)))
1147
1148 ;;;
1149
1150 (defmethod region-equal ((xs standard-rectangle-set) (ys standard-rectangle-set))
1151 ;; Our bands representation is canonic
1152 (equal (standard-rectangle-set-bands xs)
1153 (standard-rectangle-set-bands ys)))
1154
1155 (defmethod region-contains-position-p ((self standard-rectangle-set) x y)
1156 (block nil
1157 (map-over-bands (lambda (y1 y2 isum)
1158 (when (<= y1 y y2)
1159 (when (isum-member x isum)
1160 (return t)))
1161 (when (> y y2)
1162 (return nil)))
1163 (standard-rectangle-set-bands self))
1164 nil))
1165
1166 (defmethod region-contains-region-p ((xs standard-rectangle-set) (point point))
1167 (multiple-value-bind (x y) (point-position point)
1168 (region-contains-position-p xs x y)))
1169
1170 ;;; ---- interval sums ----------------------------------------------------------------------------------
1171
1172 (defun isum-union* (xs ys) (isum-op xs ys boole-ior 0 0 nil))
1173 (defun isum-difference* (xs ys) (isum-op xs ys boole-andc2 0 0 nil))
1174 (defun isum-intersection* (xs ys) (isum-op xs ys boole-and 0 0 nil))
1175
1176 ;; You could optimize all this like hell, but I better let the code
1177 ;; alone.
1178 ;; BTW this is the first time I make use of boole-xyz
1179
1180 (defun isum-op (as bs boole-op in-a in-b x0)
1181 (let (x)
1182 (cond ((and (null as) (null bs))
1183 nil)
1184 (t
1185 (cond ((null bs)
1186 (setq in-a (- 1 in-a))
1187 (setq x (pop as)))
1188
1189 ((null as)
1190 (setq in-b (- 1 in-b))
1191 (setq x (pop bs)))
1192
1193 ((< (first as) (first bs))
1194 (setq in-a (- 1 in-a))
1195 (setq x (pop as)))
1196
1197 ((< (first bs) (first as))
1198 (setq in-b (- 1 in-b))
1199 (setq x (pop bs)))
1200
1201 (t
1202 (setq in-a (- 1 in-a)
1203 in-b (- 1 in-b))
1204 (setq x (pop as))
1205 (pop bs)))
1206
1207 (cond ((zerop (boole boole-op in-a in-b))
1208 (if x0
1209 (list* x0 x (isum-op as bs boole-op in-a in-b nil))
1210 (isum-op as bs boole-op in-a in-b x0)))
1211 (t
1212 (if (null x0)
1213 (isum-op as bs boole-op in-a in-b x)
1214 (isum-op as bs boole-op in-a in-b x0))))))))
1215
1216 ;;; ---- Bands ------------------------------------------------------------------------------------------
1217
1218
1219 ;; A band list is represented by
1220
1221 ;; ((x_0 . a_0) (x_1 . a_1) ... (x_n . nil))
1222
1223 ;; The a_i are the relevant interval sums for x in [x_i, x_(i+1)].
1224
1225 ;; The empty band could have been representated as
1226 ;; ((x . nil)) x arbitrary
1227 ;; But to get a cononic representation, I'll choose simply NIL.
1228
1229 ;; A better representation would be
1230 ;; (x_0 a_0 x_1 a_1 ... x_n)
1231 ;; Pro: Unlimited bands could be represented by simply skipping the
1232 ;; first or last 'x'. So similar representation could apply to
1233 ;; interval sums also. But I let the representation as it is, since
1234 ;; this version is well tested.
1235
1236 (defun bands-op (as bs isum-op z0 a b)
1237 (let (z1)
1238 (cond ((and (null as) (null bs))
1239 (if z0
1240 (list (cons z0 nil))
1241 nil))
1242 (t
1243 (setq z1 (cond ((null as) (caar bs))
1244 ((null bs) (caar as))
1245 (t (min (caar as) (caar bs)))))
1246 (let ((rest (bands-op (if (and as (= z1 (caar as))) (cdr as) as)
1247 (if (and bs (= z1 (caar bs))) (cdr bs) bs)
1248 isum-op
1249 z1
1250 (if (and as (= z1 (caar as))) (cdar as) a)
1251 (if (and bs (= z1 (caar bs))) (cdar bs) b)))
1252 (isum (funcall isum-op a b)))
1253 (if z0
1254 (if (and rest (equal isum (cdar rest)))
1255 (cons (cons z0 isum)
1256 (cdr rest))
1257 (cons (cons z0 isum)
1258 rest))
1259 rest))) )))
1260
1261 (defun canon-empty-bands (x)
1262 (cond ((null (cdr x)) nil)
1263 (t x)))
1264
1265 (defun bands-union (as bs)
1266 (canon-empty-bands (bands-op as bs #'isum-union* nil nil nil)))
1267
1268 (defun bands-intersection (as bs)
1269 (canon-empty-bands (bands-op as bs #'isum-intersection* nil nil nil)))
1270
1271 (defun bands-difference (as bs)
1272 (canon-empty-bands (bands-op as bs #'isum-difference* nil nil nil)))
1273
1274
1275 (defun rectangle->xy-bands* (x1 y1 x2 y2)
1276 (list (list y1 x1 x2)
1277 (cons y2 nil)))
1278
1279 (defun rectangle->yx-bands* (x1 y1 x2 y2)
1280 (list (list x1 y1 y2)
1281 (cons x2 nil)))
1282
1283 (defun xy-bands->yx-bands (bands)
1284 ;; Das kann man sicherlich noch viel geschicker machen ...
1285 (let ((res nil))
1286 (map-over-bands-rectangles (lambda (x1 y1 x2 y2)
1287 (setf res (bands-union res (rectangle->yx-bands* x1 y1 x2 y2))))
1288 bands)
1289 res))
1290
1291 (defun map-over-bands-rectangles (fun bands)
1292 (map-over-bands (lambda (y1 y2 isum)
1293 (do ((p isum (cddr p)))
1294 ((null p))
1295 (funcall fun (car p) y1 (cadr p) y2)))
1296 bands))
1297
1298 (defun map-over-bands (fun bands)
1299 (do ((q bands (cdr q)))
1300 ((null (cdr q)))
1301 (funcall fun (caar q) (caadr q) (cdar q))))
1302
1303 (defun isum-member (elt isum)
1304 (cond ((null isum) nil)
1305 ((< elt (car isum)) nil)
1306 ((<= elt (cadr isum)) t)
1307 (t (isum-member elt (cddr isum)))))
1308
1309 (defun rectangle->standard-rectangle-set (rect)
1310 (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rect)
1311 (make-instance 'standard-rectangle-set :bands (rectangle->xy-bands* x1 y1 x2 y2))))
1312
1313 (defmethod transform-region (tr (self standard-rectangle-set))
1314 (cond ((scaling-transformation-p tr)
1315 (multiple-value-bind (mxx mxy myx myy tx ty)
1316 (get-transformation tr)
1317 (declare (ignore mxy myx))
1318 (let ((rev-x-p (< mxx 0))
1319 (rev-y-p (< myy 0)))
1320 (flet ((correct (bands)
1321 (loop for ((y . nil) (nil . xs)) on (nreverse bands)
1322 collect `(,y . ,xs))))
1323 (make-standard-rectangle-set
1324 (loop for band in (standard-rectangle-set-bands self)
1325 for new-band = (loop for x in (cdr band)
1326 collect (+ (* mxx x) tx) into new-xs
1327 finally (return (cons (+ (* myy (car band)) ty)
1328 (if rev-x-p
1329 (nreverse new-xs)
1330 new-xs))))
1331 collect new-band into new-bands
1332 finally (return (if rev-y-p
1333 (correct new-bands)
1334 new-bands))))))))
1335 (t
1336 ;; We have insufficient knowledge about the transformation,
1337 ;; so we have to take the union of all transformed rectangles.
1338 ;; Maybe there is a faster way to do this.
1339 (let ((res +nowhere+))
1340 (map-over-region-set-regions
1341 (lambda (rect)
1342 (setf res (region-union res (transform-region tr rect))))
1343 self)
1344 res)) ))
1345
1346 ;;; ====================================================================================================
1347
1348 (defclass standard-bounding-rectangle (standard-rectangle) ())
1349
1350 (defmethod region-equal ((a everywhere-region) (b everywhere-region))
1351 t)
1352
1353 (defmethod region-equal ((a nowhere-region) (b nowhere-region))
1354 t)
1355
1356 (defmethod region-equal ((a everywhere-region) (b region))
1357 nil)
1358
1359 (defmethod region-equal ((a nowhere-region) (b region))
1360 nil)
1361
1362 (defmethod region-equal ((a region) (b everywhere-region))
1363 nil)
1364
1365 (defmethod region-equal ((a region) (b nowhere-region))
1366 nil)
1367
1368 (defmethod region-equal ((a standard-rectangle) (b standard-rectangle))
1369 (multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* a)
1370 (multiple-value-bind (u1 v1 u2 v2) (rectangle-edges* b)
1371 (and (coordinate= x1 u1)
1372 (coordinate= y1 v1)
1373 (coordinate= x2 u2)
1374 (coordinate= y2 v2)))))
1375
1376 (defmethod region-equal ((a standard-rectangle) (b path)) nil)
1377 (defmethod region-equal ((a path) (b standard-rectangle)) nil)
1378
1379 (defmethod transform-region (tr (self everywhere-region)) (declare (ignore tr)) +everywhere+)
1380 (defmethod transform-region (tr (self nowhere-region)) (declare (ignore tr)) +nowhere+)
1381
1382 (defmethod region-contains-position-p ((self everywhere-region) x y)
1383 (declare (ignore x y))
1384 t)
1385
1386 (defmethod region-contains-position-p ((self nowhere-region) x y)
1387 (declare (ignore x y))
1388 nil)
1389
1390 (defmethod region-contains-position-p ((self standard-region-union) x y)
1391 (some (lambda (r) (region-contains-position-p r x y))
1392 (standard-region-set-regions self)))
1393
1394 (defmethod region-contains-position-p ((self standard-region-intersection) x y)
1395 (every (lambda (r) (region-contains-position-p r x y))
1396 (standard-region-set-regions self)))
1397
1398 (defmethod region-contains-position-p ((self standard-region-difference) x y)
1399 (and (region-contains-position-p (standard-region-difference-a self) x y)
1400 (not (region-contains-position-p (standard-region-difference-b self) x y))))
1401
1402 ;; Trivial set operations
1403
1404 (defmethod region-union ((a everywhere-region) (b region)) +everywhere+)
1405 (defmethod region-union ((a region) (b everywhere-region)) +everywhere+)
1406 (defmethod region-union ((a nowhere-region) (b region)) b)
1407 (defmethod region-union ((a region) (b nowhere-region)) a)
1408
1409 (defmethod region-intersection ((a everywhere-region) (b region)) b)
1410 (defmethod region-intersection ((a region) (b everywhere-region)) a)
1411 (defmethod region-intersection ((a nowhere-region) (b region)) +nowhere+)
1412 (defmethod region-intersection ((a region) (b nowhere-region)) +nowhere+)
1413
1414 ;;;(defmethod region-difference ((a everywhere-region) (b region)) b)
1415 (defmethod region-difference ((a region) (b everywhere-region)) +nowhere+) ;mit ohne alles
1416 (defmethod region-difference ((a nowhere-region) (b region)) +nowhere+)
1417 (defmethod region-difference ((a region) (b nowhere-region)) a)
1418
1419
1420 ;; dimensionally rule
1421 (defmethod region-union ((a area) (b path)) a)
1422 (defmethod region-union ((a path) (b point)) a)
1423 (defmethod region-union ((a area) (b point)) a)
1424 (defmethod region-union ((a path) (b area)) b)
1425 (defmethod region-union ((a point) (b path)) b)
1426 (defmethod region-union ((a point) (b area)) b)
1427
1428 (defmethod transform-region (tr (self standard-region-difference))
1429 (with-slots (a b) self
1430 (make-instance 'standard-region-difference
1431 :a (transform-region tr a)
1432 :b (transform-region tr b))))
1433
1434 (defmethod transform-region (tr (self standard-region-union))
1435 (with-slots (regions) self
1436 (make-instance 'standard-region-union :regions (mapcar (lambda (r) (transform-region tr r)) regions))))
1437
1438 (defmethod transform-region (tr (self standard-region-intersection))
1439 (with-slots (regions) self
1440 (make-instance 'standard-region-intersection :regions (mapcar (lambda (r) (transform-region tr r)) regions))))
1441
1442
1443 (defmethod region-set-regions ((self standard-region-union) &key normalize)
1444 (declare (ignorable normalize))
1445 (standard-region-set-regions self))
1446
1447 (defmethod region-set-regions ((self standard-region-intersection) &key normalize)
1448 (declare (ignorable normalize))
1449 (standard-region-set-regions self))
1450
1451 (defmethod region-set-regions ((self standard-region-difference) &key normalize)
1452 (declare (ignorable normalize))
1453 (list (standard-region-difference-a self)
1454 (standard-region-difference-b self)))
1455
1456 (defmethod region-set-regions ((self region) &key normalize)
1457 (declare (ignorable normalize))
1458 (list self))
1459
1460 (defmethod map-over-region-set-regions (fun (self standard-region-union) &key normalize)
1461 (declare (ignorable normalize))
1462 (mapc fun (standard-region-set-regions self)))
1463
1464 (defmethod map-over-region-set-regions (fun (self standard-region-intersection) &key normalize)
1465 (declare (ignorable normalize))
1466 (mapc fun (standard-region-set-regions self)))
1467
1468 (defmethod map-over-region-set-regions (fun (self standard-region-difference) &key normalize)
1469 (declare (ignorable normalize))
1470 (funcall fun (standard-region-difference-a self))
1471 (funcall fun (standard-region-difference-b self)))
1472
1473 (defmethod map-over-region-set-regions (fun (self region) &key normalize)
1474 (declare (ignorable normalize))
1475 (funcall fun self))
1476
1477 (defun line-intersection* (x1 y1 x2 y2 u1 v1 u2 v2)
1478 (let ((dx (- x2 x1)) (dy (- y2 y1))
1479 (du (- u2 u1)) (dv (- v2 v1)))
1480 (let ((q (- (* dx dv) (* du dy))))
1481 (cond ((not (and (<= (min x1 x2) (max u1 u2)) (<= (min u1 u2) (max x1 x2))
1482 (<= (min y1 y2) (max v1 v2)) (<= (min v1 v2) (max y1 y2))))
1483 nil)
1484 ((coordinate= 0 q)
1485 (cond ((coordinate= (* (- v1 y1) dx) (* (- u1 x1) dy))
1486 ;; koninzident
1487 (cond ((> (abs dx) (abs dy))
1488 (let* ((sx1 (max (min x1 x2) (min u1 u2)))
1489 (sx2 (min (max x1 x2) (max u1 u2)))
1490 (sy1 (+ (* (- sx1 x1) (/ dy dx)) x1))
1491 (sy2 (+ (* (- sx2 x1) (/ dy dx)) x1)))
1492 (values :coincident sx1 sy1 sx2 sy2)))
1493 (t
1494 (let* ((sy1 (max (min y1 y2) (min v1 v2)))
1495 (sy2 (min (max y1 y2) (max v1 v2)))
1496 (sx1 (+ (* (- sy1 y1) (/ dx dy)) y1))
1497 (sx2 (+ (* (- sy2 y1) (/ dx dy)) y1)))
1498 (values :coincident sx1 sy1 sx2 sy2)))))
1499 (t
1500 ;;paralell -- kein Schnitt
1501 nil)))
1502 (t
1503 (let ((x (/ (+ (* dx (- (* u1 dv) (* v1 du))) (* du (- (* y1 dx) (* x1 dy)))) q))
1504 (y (/ (+ (* dy (- (* u1 dv) (* v1 du))) (* dv (- (* y1 dx) (* x1 dy)))) q)))
1505 (if (and (or (<= x1 x x2) (<= x2 x x1))
1506 (or (<= u1 x u2) (<= u2 x u1))
1507 (or (<= y1 y y2) (<= y2 y y1))
1508 (or (<= v1 y v2) (<= v2 y v1)))
1509 (values :hit x y)
1510 nil)) ) )) ))
1511
1512 (defmethod region-intersection ((a standard-line) (b standard-line))
1513 (multiple-value-bind (x1 y1) (line-start-point* a)
1514 (multiple-value-bind (x2 y2) (line-end-point* a)
1515 (multiple-value-bind (u1 v1) (line-start-point* b)
1516 (multiple-value-bind (u2 v2) (line-end-point* b)
1517 (multiple-value-bind (r sx1 sy1 sx2 sy2) (line-intersection* x1 y1 x2 y2 u1 v1 u2 v2)
1518 (case r
1519 (:hit (make-point sx1 sy1))
1520 (:coincident (make-line* sx1 sy1 sx2 sy2))
1521 ((nil) +nowhere+))))))))
1522
1523 ;; IHMO the CLIM dimensionality rule is brain dead!
1524
1525 (defmethod region-intersection ((a standard-polyline) (b region))
1526 (let ((res +nowhere+))
1527 ;; hack alert
1528 (map-over-polygon-segments
1529 (lambda (x1 y1 x2 y2)
1530 (setf res (region-union res (region-intersection (make-line* x1 y1 x2 y2) b))))
1531 a)
1532 res))
1533
1534 (defmethod region-difference ((a standard-polyline) (b region))
1535 (let ((res +nowhere+))
1536 (map-over-polygon-segments
1537 (lambda (x1 y1 x2 y2)
1538 (setf res (region-union res (region-difference (make-line* x1 y1 x2 y2) b))))
1539 a)
1540 res))
1541
1542 (defmethod region-difference ((a region) (b standard-polyline))
1543 (map-over-polygon-segments
1544 (lambda (x1 y1 x2 y2)
1545 (setf a (region-difference a (make-line* x1 y1 x2 y2))))
1546 b)
1547 a)
1548
1549 (defmethod region-intersection ((b region) (a standard-polyline))
1550 (region-intersection a b))
1551
1552 (defmethod region-intersection ((a region) (p point))
1553 (multiple-value-bind (x y) (point-position p)
1554 (if (region-contains-position-p a x y)
1555 p
1556 +nowhere+)))
1557
1558 (defmethod region-intersection ((p point) (a region))
1559 (region-intersection a p))
1560
1561 (defmethod region-intersection ((a standard-region-union) (b region))
1562 (let ((res +nowhere+))
1563 (map-over-region-set-regions (lambda (r) (setf res (region-union res (region-intersection r b)))) a)
1564 res))
1565
1566 (defmethod region-intersection ((a region) (b standard-region-union))
1567 (region-intersection b a))
1568
1569 (defmethod region-intersection ((a standard-rectangle-set) (b region))
1570 (let ((res +nowhere+))
1571 (map-over-region-set-regions (lambda (r) (setf res (region-union res (region-intersection r b)))) a)
1572 res))
1573
1574 (defmethod region-intersection ((a region) (b standard-rectangle-set))
1575 (region-intersection b a))
1576
1577 (defmethod region-intersection ((a region) (b standard-region-intersection))
1578 (map-over-region-set-regions (lambda (r) (setf a (region-intersection a r))) b)
1579 a)
1580
1581 (defmethod region-intersection ((a standard-region-intersection) (b region))
1582 (region-intersection b a))
1583
1584 (defmethod region-intersection ((a region) (b region))
1585 (make-instance 'standard-region-intersection :regions (list a b)))
1586
1587
1588 (defmethod region-intersection ((x region) (y standard-region-difference))
1589 (with-slots (a b) y
1590 (region-difference (region-intersection x a) b)))
1591
1592 (defmethod region-intersection ((x standard-region-difference) (y region))
1593 (with-slots (a b) x
1594 (region-difference (region-intersection y a) b)))
1595
1596
1597
1598 (defmethod region-difference ((x area) (y path)) x)
1599 (defmethod region-difference ((x area) (y point)) x)
1600 (defmethod region-difference ((x path) (y point)) x)
1601
1602 (defmethod region-difference ((x everywhere-region) (y region))
1603 (make-instance 'standard-region-difference :a x :b y))
1604
1605 (defmethod region-difference ((x everywhere-region) (y nowhere-region))
1606 x)
1607
1608 (defmethod region-difference ((x everywhere-region) (y everywhere-region))
1609 +nowhere+)
1610
1611 (defmethod region-difference ((x region) (y standard-region-difference))
1612 (with-slots (a b) y
1613 (region-union (region-difference x a) (region-intersection x b))))
1614
1615 (defmethod region-difference ((x region) (y standard-region-union))
1616 ;; A \ (B1 u B2 .. u Bn) = ((((A \ B1) \ B2) ... ) \ Bn)
1617 (let ((res x))
1618 (map-over-region-set-regions (lambda (a)
1619 (setf res (region-difference res a)))
1620 y)
1621 res))
1622
1623 (defmethod region-difference ((x standard-region-union) (y region))
1624 ;; (A u B) \ C = A\C u B\C
1625 (let ((res +nowhere+))
1626 (map-over-region-set-regions (lambda (a)
1627 (setf res (region-union res (region-difference a y))))
1628 x)
1629 res))
1630
1631 (defmethod region-difference ((x region) (y standard-rectangle-set))
1632 (let ((res x))
1633 (map-over-region-set-regions (lambda (a)
1634 (setf res (region-difference res a)))
1635 y)
1636 res))
1637
1638 (defmethod region-difference ((x standard-rectangle-set) (y region))
1639 (let ((res +nowhere+))
1640 (map-over-region-set-regions (lambda (a)
1641 (setf res (region-union res (region-difference a y))))
1642 x)
1643 res))
1644
1645 (defmethod region-difference ((x point) (y region))
1646 (multiple-value-bind (px py) (point-position x)
1647 (if (region-contains-position-p y px py)
1648 +nowhere+
1649 x)))
1650
1651 (defmethod region-difference ((x standard-region-difference) (y region))
1652 ;; (A\B)\C = A \ (B u C)
1653 (with-slots (a b) x
1654 (region-difference a (region-union b y))))
1655
1656 (defmethod region-difference ((x region) (y standard-region-intersection))
1657 (let ((res +nowhere+))
1658 (map-over-region-set-regions (lambda (b)
1659 (setf res (region-union res (region-difference x b))))
1660 y)
1661 res))
1662
1663 ;; Diese CLIM dimensionality rule ist in hoechsten ma?e inkonsistent
1664 ;; und bringt mehr probleme als sie beseitigt.
1665
1666
1667
1668 ;;; ---- Set operations on polygons ---------------------------------------------------------------------
1669
1670 (defstruct (pg-edge (:constructor make-pg-edge* (x1 y1 x2 y2 extra)))
1671 x1 y1 x2 y2 extra)
1672
1673 (defstruct pg-splitter
1674 links ;liste von punkten
1675 rechts) ; von unten nach oben
1676
1677 (defun make-pg-edge (p1 p2 extra)
1678 (multiple-value-bind (x1 y1) (point-position p1)
1679 (multiple-value-bind (x2 y2) (point-position p2)
1680 (make-pg-edge* x1 y1 x2 y2 extra))))
1681
1682
1683 (defmethod region-intersection ((a standard-polygon) (b standard-polygon))
1684 (polygon-op a b #'logand))
1685
1686 (defmethod region-union ((a standard-polygon) (b standard-polygon))
1687 (polygon-op a b #'logior))
1688
1689 (defmethod region-difference ((a standard-polygon) (b standard-polygon))
1690 (polygon-op a b #'logandc2))
1691
1692 (defmethod region-intersection ((a standard-polygon) (b standard-rectangle))
1693 (polygon-op a b #'logand))
1694
1695 (defmethod region-union ((a standard-polygon) (b standard-rectangle))
1696 (polygon-op a b #'logior))
1697
1698 (defmethod region-difference ((a standard-polygon) (b standard-rectangle))
1699 (polygon-op a b #'logandc2))
1700
1701 (defmethod region-intersection ((a standard-rectangle) (b standard-polygon))
1702 (polygon-op a b #'logand))
1703
1704 (defmethod region-union ((a standard-rectangle) (b standard-polygon))
1705 (polygon-op a b #'logior))
1706
1707 (defmethod region-difference ((a standard-rectangle) (b standard-polygon))
1708 (polygon-op a b #'logandc2))
1709
1710 (defun polygon-op (pg1 pg2 &optional logop)
1711 (let ((sps nil))
1712 (over-sweep-bands pg1 pg2
1713 (lambda (sy0 sy1 S &aux (ys nil))
1714 (setq ys (list sy0 sy1))
1715 (dolist (k1 S)
1716 (dolist (k2 S)
1717 (multiple-value-bind (px py)
1718 (line-intersection** (pg-edge-x1 k1) (pg-edge-y1 k1)
1719 (pg-edge-x2 k1) (pg-edge-y2 k1)
1720 (pg-edge-x1 k2) (pg-edge-y1 k2)
1721 (pg-edge-x2 k2) (pg-edge-y2 k2))
1722 (when (and px (< sy0 py sy1))
1723 (pushnew py ys :test #'coordinate=)))))
1724 (setq ys (sort ys #'<))
1725 (do ((q ys (cdr q)))
1726 ((null (cdr q)))
1727 (let ((by0 (car q)) (by1 (cadr q))
1728 (R nil))
1729 (dolist (k S)
1730 (when (> (pg-edge-y2 k) (pg-edge-y1 k))
1731 (multiple-value-bind (x1 y1 x2 y2)
1732 (restrict-line-on-y-interval* (pg-edge-x1 k) (pg-edge-y1 k)
1733 (pg-edge-x2 k) (pg-edge-y2 k)
1734 by0 by1)
1735 (declare (ignore y1 y2))
1736 (push (list x1 x2 (pg-edge-extra k)) R))))
1737 (setq R (sort R #'< :key (lambda (x) (+ (first x) (second x)))))
1738 (labels
1739 ((add (lo lu ro ru)
1740 (dolist (s sps
1741 ;; ansonsten
1742 (push (make-pg-splitter :links (list lu lo)
1743 :rechts (list ru ro))
1744 sps) )
1745 (when (and (region-equal lo (car (pg-splitter-links s)))
1746 (region-equal ro (car (pg-splitter-rechts s))))
1747 (push lu (pg-splitter-links s))
1748 (push ru (pg-splitter-rechts s))
1749 (return))) ))
1750 (let ((eintritt nil)
1751 (ina 0)
1752 (inb 0))
1753 (dolist (k R)
1754 (ecase (third k)
1755 (:a (setq ina (- 1 ina)))
1756 (:b (setq inb (- 1 inb))))
1757 (cond ((/= 0 (funcall logop ina inb))
1758 (when (null eintritt)
1759 (setq eintritt k)))
1760 (t
1761 (when eintritt
1762 (add (make-point (first eintritt) by0)
1763 (make-point (second eintritt) by1)
1764 (make-point (first k) by0)
1765 (make-point (second k) by1))
1766 (setq eintritt nil)) )))) ) )) ) )
1767 (setq sps (delete +nowhere+ (mapcar #'pg-splitter->polygon sps)))
1768 (cond ((null sps) +nowhere+)
1769 ((null (cdr sps))
1770 (car sps))
1771 ((make-instance 'standard-region-union :regions sps))) ))
1772
1773 (defun over-sweep-bands (pg1 pg2 fun)
1774 (let ((es (nconc (polygon->pg-edges pg1 :a) (polygon->pg-edges pg2 :b))))
1775 (setq es (sort es #'< :key #'pg-edge-y1))
1776 (let ((ep es)
1777 (sy (pg-edge-y1 (car es)))
1778 (S nil))
1779 (do () ((null ep))
1780 (setq S (delete-if (lambda (e)
1781 (<= (pg-edge-y2 e) sy))
1782 S))
1783
1784 (do () ((or (null ep) (/= sy (pg-edge-y1 (car ep)))))
1785 (push (pop ep) S))
1786
1787 (let ((sy2 (or (and ep (pg-edge-y1 (car ep)))
1788 (reduce #'max (mapcar #'pg-edge-y2 S)))))
1789
1790 (funcall fun sy sy2 S)
1791 (setq sy sy2)) ))))
1792
1793 (defun polygon->pg-edges (pg extra)
1794 (let ((pts (polygon-points pg))
1795 (res nil))
1796 (let ((prev pts)
1797 (cur (cdr pts))
1798 (next (cddr pts)))
1799 (loop
1800 (when (or (> (point-y (car next)) (point-y (car cur)))
1801 (and (= (point-y (car next)) (point-y (car cur)))
1802 (> (point-x (car next)) (point-x (car cur)))))
1803 (push (make-pg-edge (car cur) (car next) extra) res))
1804 (when (or (> (point-y (car prev)) (point-y (car cur)))
1805 (and (= (point-y (car prev)) (point-y (car cur)))
1806 (> (point-x (car prev)) (point-x (car cur)))))
1807 (push (make-pg-edge (car cur) (car prev) extra) res))
1808 (when (not (or (> (point-y (car next)) (point-y (car cur)))
1809 (and (= (point-y (car next)) (point-y (car cur)))
1810 (> (point-x (car next)) (point-x (car cur))))
1811 (> (point-y (car next)) (point-y (car cur)))
1812 (and (= (point-y (car next)) (point-y (car cur)))
1813 (> (point-x (car next)) (point-x (car cur))))))
1814 (push (make-pg-edge (car cur) (car cur) extra) res))
1815 (psetq prev cur
1816 cur next
1817 next (or (cdr next) pts))
1818 (when (eq prev pts)
1819 (return)) ))
1820 res))
1821
1822 (defun restrict-line-on-y-interval* (x1 y1 x2 y2 ry0 ry1)
1823 (let ((dx (- x2 x1))
1824 (dy (- y2 y1)))
1825 (values (+ (* (- ry0 y1) (/ dx dy)) x1) ry0
1826 (+ (* (- ry1 y1) (/ dx dy)) x1) ry1)))
1827
1828 (defun pg-splitter->polygon (s)
1829 (make-polygon (clean-up-point-sequence (nconc (pg-splitter-links s) (reverse (pg-splitter-rechts s))))))
1830
1831 (defun clean-up-point-sequence (pts)
1832 (cond ((null (cdr pts)) pts)
1833 ((region-equal (car pts) (cadr pts))
1834 (clean-up-point-sequence (cdr pts)))
1835 ((null (cddr pts)) pts)
1836 ((colinear-p (car pts) (cadr pts) (caddr pts))
1837 (clean-up-point-sequence (list* (car pts) (caddr pts) (cdddr pts))))
1838 (t
1839 (cons (car pts) (clean-up-point-sequence (cdr pts)))) ))
1840
1841 (defun colinear-p (p1 p2 p3)
1842 (multiple-value-bind (x1 y1) (point-position p1)
1843 (multiple-value-bind (x2 y2) (point-position p2)
1844 (multiple-value-bind (x3 y3) (point-position p3)
1845 (coordinate= (* (- x2 x1) (- y3 y2))
1846 (* (- x3 x2) (- y2 y1)))))))
1847
1848 (defun line-intersection** (x1 y1 x2 y2 u1 v1 u2 v2)
1849 (let ((dx (- x2 x1)) (dy (- y2 y1))
1850 (du (- u2 u1)) (dv (- v2 v1)))
1851 (let ((q (- (* dx dv) (* du dy))))
1852 (cond ((coordinate= 0 q)
1853 nil)
1854 (t
1855 (let ((x (/ (+ (* dx (- (* u1 dv) (* v1 du))) (* du (- (* y1 dx) (* x1 dy)))) q))
1856 (y (/ (+ (* dy (- (* u1 dv) (* v1 du))) (* dv (- (* y1 dx) (* x1 dy)))) q)))
1857 (values x y)))))))
1858
1859 ;;; -----------------------------------------------------------------------------------------------------
1860
1861 (defmethod region-union ((a standard-region-union) (b nowhere-region))
1862 a)
1863
1864 (defmethod region-union ((b nowhere-region) (a standard-region-union))
1865 a)
1866
1867 (defmethod region-union ((a standard-region-union) (b region))
1868 (assert (not (eq b +nowhere+)))
1869 (make-instance 'standard-region-union :regions (cons b (standard-region-set-regions a))))
1870
1871 (defmethod region-union ((b region) (a standard-region-union))
1872 (assert (not (eq b +nowhere+)))
1873 (make-instance 'standard-region-union :regions (cons b (standard-region-set-regions a))))
1874
1875 (defmethod region-union ((a standard-region-union) (b standard-region-union))
1876 (assert (not (eq b +nowhere+)))
1877 (assert (not (eq a +nowhere+)))
1878 (make-instance 'standard-region-union
1879 :regions (append (standard-region-set-regions a) (standard-region-set-regions b))))
1880
1881 (defmethod region-union ((a region) (b region))
1882 (make-instance 'standard-region-union :regions (list a b)))
1883
1884 (defmethod region-union ((a standard-rectangle-set) (b path)) a)
1885 (defmethod region-union ((b path) (a standard-rectangle-set)) a)
1886 (defmethod region-union ((a standard-rectangle-set) (b point)) a)
1887 (defmethod region-union ((b point) (a standard-rectangle-set)) a)
1888
1889 ;;; ---- Intersection Line/Polygon ----------------------------------------------------------------------
1890
1891 (defun geraden-schnitt/prim (x1 y1 x12 y12 x2 y2 x22 y22)
1892 (let ((dx1 (- x12 x1)) (dy1 (- y12 y1))
1893 (dx2 (- x22 x2)) (dy2 (- y22 y2)))
1894 ;; zwei geraden gegeben als
1895 ;; g : s -> (x1 + s*dx1, y1 + s*dy1)
1896 ;; h : t -> (x2 + t*dx2, y2 + t*dy2)
1897 ;; -> NIL | (s ; t)
1898 (let ((quot (- (* DX2 DY1) (* DX1 DY2))))
1899 (if (coordinate= quot 0)
1900 nil
1901 (values
1902 (- (/ (+ (* DX2 (- Y1 Y2)) (* DY2 X2) (- (* DY2 X1))) quot))
1903 (- (/ (+ (* DX1 (- Y1 Y2)) (* DY1 X2) (- (* DY1 X1))) quot)))) )) )
1904
1905 (defun geraden-gleichung (x0 y0 x1 y1 px py)
1906 ;; ??? This somehow tries to calculate the distance between a point
1907 ;; and a line. The sign of the result depends upon the side the point
1908 ;; is on wrt to the line. --GB
1909 (- (* (- py y0) (- x1 x0))
1910 (* (- px x0) (- y1 y0))))
1911
1912 (defun position->geraden-fktn-parameter (x0 y0 x1 y1 px py)
1913 (let ((dx (- x1 x0)) (dy (- y1 y0)))
1914 (if (> (abs dx) (abs dy))
1915 (/ (- px x0) dx)
1916 (/ (- py y0) dy))))
1917
1918 (defun map-over-schnitt-gerade/polygon (fun x1 y1 x2 y2 points)
1919 ;; This calles 'fun' with the "Geradenfunktionsparameter" of each
1920 ;; intersection of the line (x1,y1),(x2,y2) and the polygon denoted
1921 ;; by 'points' in a "sensible" way. --GB
1922 (let ((n (length points)))
1923 (dotimes (i n)
1924 (let ((pv (elt points (mod (- i 1) n))) ;the point before
1925 (po (elt points (mod i n))) ;the "current" point
1926 (pn (elt points (mod (+ i 1) n))) ;the point after
1927 (pnn (elt points (mod (+ i 2) n)))) ;the point after**2
1928 (cond
1929 ;; The line goes directly thru' po
1930 ((line-contains-point-p** x1 y1 x2 y2 (point-x po) (point-y po))
1931 (let ((sign-1 (geraden-gleichung x1 y1 x2 y2 (point-x pn) (point-y pn)))
1932 (sign-2 (geraden-gleichung x1 y1 x2 y2 (point-x pv) (point-y pv))))
1933 (cond ((or (and (> sign-1 0) (< sign-2 0))
1934 (and (< sign-1 0) (> sign-2 0)))
1935 ;; clear cases: the line croses the polygon's border
1936 (funcall fun (position->geraden-fktn-parameter x1 y1 x2 y2 (point-x po) (point-y po)) ))
1937 ((= sign-1 0)
1938 ;; more difficult:
1939 ;; The line is coincident with the edge po/pn
1940 (let ((sign-1 (geraden-gleichung x1 y1 x2 y2 (point-x pnn) (point-y pnn))))
1941 (cond ((or (and (> sign-1 0) (< sign-2 0))
1942 (and (< sign-1 0) (> sign-2 0)))
1943 ;; The line goes through the polygons border, by edge po/pn
1944 (funcall fun (position->geraden-fktn-parameter x1 y1 x2 y2 (point-x po) (point-y po)) ))
1945 (t
1946 ;; otherwise the line touches the polygon at the edge po/pn,
1947 ;; return both points
1948 (funcall fun (position->geraden-fktn-parameter x1 y1 x2 y2 (point-x po) (point-y po)) )
1949 (funcall fun (position->geraden-fktn-parameter x1 y1 x2 y2 (point-x pn) (point-y pn)) ) ))))
1950 (t
1951 ;; all other cases: Line either touches polygon in
1952 ;; a point or in an edge [handled above]. --GB
1953 nil) )))
1954 ((line-contains-point-p** x1 y1 x2 y2 (point-x pn) (point-y pn))
1955 nil)
1956 (t
1957 (multiple-value-bind (k m)
1958 (geraden-schnitt/prim x1 y1 x2 y2 (point-x po) (point-y po) (point-x pn) (point-y pn))
1959 (when (and k (<= 0 m 1)) ;Moegliche numerische Instabilitaet
1960 (funcall fun k)))))))))
1961
1962 (defun schnitt-gerade/polygon-prim (x1 y1 x2 y2 points)
1963 (let ((res nil))
1964 (map-over-schnitt-gerade/polygon (lambda (k) (push k res)) x1 y1 x2 y2 points)
1965 (sort res #'<)))
1966
1967 (defun schnitt-line/polygon (x1 y1 x2 y2 polygon)
1968 (let ((ks (schnitt-gerade/polygon-prim x1 y1 x2 y2 (polygon-points polygon))))
1969 (assert (evenp (length ks)))
1970 (let ((res nil))
1971 (do ((q ks (cddr q)))
1972 ((null q))
1973 (let ((k1 (max 0d0 (min 1d0 (car q))))
1974 (k2 (max 0d0 (min 1d0 (cadr q)))))
1975 (when (/= k1 k2)
1976 (push (make-line* (+ x1 (* k1 (- x2 x1))) (+ y1 (* k1 (- y2 y1)))
1977 (+ x1 (* k2 (- x2 x1))) (+ y1 (* k2 (- y2 y1))))
1978 res))))
1979 (cond ((null res) +nowhere+)
1980 ((null (cdr res)) (car res))
1981 (t (make-instance 'standard-region-union :regions res)) ))))
1982
1983 (defmethod region-contains-position-p ((pg polygon) x y)
1984 (setf x (coerce x 'coordinate))
1985 (setf y (coerce y 'coordinate))
1986 (let ((n 0) (m 0))
1987 (map-over-schnitt-gerade/polygon (lambda (k)
1988 (when (>= k 0) (incf n))
1989 (incf m))
1990 x y (+ x 1) y (polygon-points pg))
1991 (assert (evenp m))
1992 (oddp n)))
1993
1994 (defmethod region-intersection ((a standard-line) (b standard-polygon))
1995 (multiple-value-bind (x1 y1) (line-start-point* a)
1996 (multiple-value-bind (x2 y2) (line-end-point* a)
1997 (schnitt-line/polygon x1 y1 x2 y2 b))))
1998
1999 (defmethod region-intersection ((b standard-polygon) (a standard-line))
2000 (multiple-value-bind (x1 y1) (line-start-point* a)
2001 (multiple-value-bind (x2 y2) (line-end-point* a)
2002 (schnitt-line/polygon x1 y1 x2 y2 b))))
2003
2004 (defmethod region-intersection ((a standard-line) (b standard-rectangle))
2005 (multiple-value-bind (x1 y1) (line-start-point* a)
2006 (multiple-value-bind (x2 y2) (line-end-point* a)
2007 (schnitt-line/polygon x1 y1 x2 y2 b))))
2008
2009 (defmethod region-intersection ((b standard-rectangle) (a standard-line))
2010 (multiple-value-bind (x1 y1) (line-start-point* a)
2011 (multiple-value-bind (x2 y2) (line-end-point* a)
2012 (schnitt-line/polygon x1 y1 x2 y2 b))))
2013
2014
2015
2016 (defmethod region-difference ((a standard-line) (b standard-polygon))
2017 (multiple-value-bind (x1 y1) (line-start-point* a)
2018 (multiple-value-bind (x2 y2) (line-end-point* a)
2019 (differenz-line/polygon x1 y1 x2 y2 b))))
2020
2021 (defmethod region-difference ((a standard-line) (b standard-rectangle))
2022 (multiple-value-bind (x1 y1) (line-start-point* a)
2023 (multiple-value-bind (x2 y2) (line-end-point* a)
2024 (differenz-line/polygon x1 y1 x2 y2 b))))
2025
2026 (defun differenz-line/polygon (x1 y1 x2 y2 polygon)
2027 (let ((ks (schnitt-gerade/polygon-prim x1 y1 x2 y2 (polygon-points polygon))))
2028 (assert (evenp (length ks)))
2029 (let ((res nil)
2030 (res2 nil))
2031 (push 0d0 res)
2032 (do ((q ks (cddr q)))
2033 ((null q))
2034 (let ((k1 (max 0d0 (min 1d0 (car q))))
2035 (k2 (max 0d0 (min 1d0 (cadr q)))))
2036 (when (/= k1 k2)
2037 (push k1 res)
2038 (push k2 res))))
2039 (push 1d0 res)
2040 (setf res (nreverse res))
2041 (do ((q res (cddr q)))
2042 ((null q))
2043 (let ((k1 (car q))
2044 (k2 (cadr q)))
2045 (when (/= k1 k2)
2046 (push (make-line* (+ x1 (* k1 (- x2 x1))) (+ y1 (* k1 (- y2 y1)))
2047 (+ x1 (* k2 (- x2 x1))) (+ y1 (* k2 (- y2 y1))))
2048 res2))))
2049 (cond ((null res2) +nowhere+)
2050 ((null (cdr res2)) (car res2))
2051 (t (make-instance 'standard-region-union :regions res2)) ))))
2052
2053
2054 (defmethod region-difference ((a standard-line) (b standard-line))
2055 (multiple-value-bind (x1 y1) (line-start-point* a)
2056 (multiple-value-bind (x2 y2) (line-end-point* a)
2057 (multiple-value-bind (u1 v1) (line-start-point* b)
2058 (multiple-value-bind (u2 v2) (line-end-point* b)
2059 (cond ((and (coordinate= 0 (geraden-gleichung x1 y1 x2 y2 u1 v1))
2060 (coordinate= 0 (geraden-gleichung x1 y1 x2 y2 u2 v2)))
2061 (let ((k1 (position->geraden-fktn-parameter x1 y1 x2 y2 u1 v1))
2062 (k2 (position->geraden-fktn-parameter x1 y1 x2 y2 u2 v2)))
2063 (psetq k1 (max 0 (min k1 k2))
2064 k2 (min 1 (max k1 k2)))
2065 (let ((r (nconc (if (> k1 0)
2066 (list (make-line* x1 y1 (+ x1 (* k1 (- x2 x1))) (+ y1 (* k1 (- y2 y1)))))
2067 nil)
2068 (if (< k2 1)
2069 (list (make-line* (+ x1 (* k2 (- x2 x1))) (+ y1 (* k2 (- y2 y1))) x2 y2))
2070 nil))))
2071 (cond ((null r) +nowhere+)
2072 ((null (cdr r)) (car r))
2073 (t (make-instance 'standard-region-union :regions r)) ))))
2074 (t
2075 a)))))))
2076
2077 (defmethod region-union ((a standard-line) (b standard-line))
2078 (multiple-value-bind (x1 y1) (line-start-point* a)
2079 (multiple-value-bind (x2 y2) (line-end-point* a)
2080 (multiple-value-bind (u1 v1) (line-start-point* b)
2081 (multiple-value-bind (u2 v2) (line-end-point* b)
2082 (cond ((and (coordinate= 0 (geraden-gleichung x1 y1 x2 y2 u1 v1))
2083 (coordinate= 0 (geraden-gleichung x1 y1 x2 y2 u2 v2)))
2084 (let ((k1 (position->geraden-fktn-parameter x1 y1 x2 y2 u1 v1))
2085 (k2 (position->geraden-fktn-parameter x1 y1 x2 y2 u2 v2)))
2086 (psetq k1 (min k1 k2)
2087 k2 (max k1 k2))
2088 (cond ((and (<= k1 1) (>= k2 0))
2089 (let ((k1 (min 0 k1))
2090 (k2 (max 1 k2)))
2091 (make-line* (+ x1 (* k1 (- x2 x1))) (+ y1 (* k1 (- y2 y1)))
2092 (+ x1 (* k2 (- x2 x1))) (+ y1 (* k2 (- y2 y1))))))
2093 (t
2094 (make-instance 'standard-region-union :regions (list a b))))))
2095 ((and (coordinate= x1 u1) (coordinate= y1 v1))
2096 (make-polyline* (list u2 v2 x1 y1 x2 y2)))
2097 ((and (coordinate= x2 u2) (coordinate= y2 v2))
2098 (make-polyline* (list x1 y1 x2 y2 u1