public Ramarren /cl-geometry

Subversion checkout URL

You can clone with HTTPS or Subversion.

Change test to use polygon class and fix some things.

commit 30d0b81cc730baddcb543415c5bcaacd9552a87c 1 parent 3f94ed3
authored
15  basic-point.lisp
 @@ -4,8 +4,8 @@ 4 4 ;;;; object) (y object). 5 5 6 6 (defclass point () 7 - ((x :accessor x :initarg :x :initform 0) 8 - (y :accessor y :initarg :y :initform 0)) 7 + ((x :reader x :initarg :x :initform 0) 8 + (y :reader y :initarg :y :initform 0)) 9 9 (:documentation "A point on a plane, with cartesian coordinates.")) 10 10 11 11 (defmethod print-object ((object point) stream) @@ -21,16 +21,11 @@ 21 21 (and (= (x point1)(x point2)) 22 22 (= (y point1)(y point2)))) 23 23 24 -(defun coords-to-points (coord-list) 24 +(defun coords-to-points (&rest coord-list) 25 25 "Coordinate list (x1 y1 x2 y2 ... xn yn) to point list" 26 26 (assert (zerop (mod (length coord-list) 2))) 27 - (labels ((recurse-list (coord-list acc) 28 - (if (null coord-list) 29 - (nreverse acc) 30 - (recurse-list (cddr coord-list) 31 - (cons (make-point (car coord-list) (cadr coord-list)) 32 - acc))))) 33 - (recurse-list coord-list nil))) 27 + (iterate (for (x y . nil) on coord-list by #'cddr) 28 + (collect (make-point x y)))) 34 29 35 30 (defun left-p (a b c) 36 31 "Is c to the left of the oriented line defined by a->b?"
8  bentley-ottmann.lisp
 @@ -83,6 +83,14 @@ 83 83 ((edge-tree :accessor edge-tree)) 84 84 (:documentation "Sweep line.")) 85 85 86 +(defgeneric (setf x) (new-value object) 87 + (:method (new-value (object sweep-line)) 88 + (setf (slot-value object 'x) new-value))) 89 + 90 +(defgeneric (setf y) (new-value object) 91 + (:method (new-value (object sweep-line)) 92 + (setf (slot-value object 'y) new-value))) 93 + 86 94 (defmethod initialize-instance :after ((instance sweep-line) &rest initargs) 87 95 "Create a tree, use closure over the sweep line as ordering function." 88 96 (declare (ignore initargs))
6  cl-geometry-tests.asd
 ... ... @@ -0,0 +1,6 @@ 1 +(asdf:defsystem :cl-geometry-tests 2 + :description "Tests for cl-geometry." 3 + :version "0" 4 + :licence "BSD" 5 + :components ((:file "test-geometry")) 6 + :depends-on (:cl-geometry :vecto :iterate))
2  decomposition.lisp
 @@ -26,7 +26,7 @@ 26 26 27 27 (defun decompose-complex-polygon-nondisjoint (polygon) 28 28 "Decomposes a complex polygon into a set of simple ones, possibly some entirely contained in others." 29 - (let ((ring-head (point-ring polygon)) 29 + (let ((ring-head (double-linked-ring-from-point-list (point-list polygon))) 30 30 (simple-polys nil)) 31 31 (let ((ring-index (collect-ring-nodes ring-head)) 32 32 (edge-list (ring-to-list-of-edges ring-head)))
10  package.lisp
 @@ -23,6 +23,9 @@ 23 23 #:end 24 24 #:line 25 25 #:A #:B #:C 26 + #:polygon 27 + #:point-list 28 + #:edge-list 26 29 #:line-y-at-x #:line-x-at-y 27 30 #:line-from-segment 28 31 #:line-segment-length @@ -49,4 +52,9 @@ 49 52 #:decompose-complex-polygon-triangles 50 53 #:polygon-union 51 54 #:polygon-intersection 52 - #:polygon-difference)) 55 + #:polygon-difference 56 + #:make-polygon-from-point-list 57 + #:make-polygon-from-point-ring 58 + #:coords-to-points 59 + #:make-polygon-from-coords)) 60 +
9  polygon-class.lisp
 @@ -3,9 +3,9 @@ 3 3 ;;; Treat polygons as immutable object, construct all representations 4 4 5 5 (defclass polygon () 6 - ((point-list :reader point-list :initarg point-list) 7 - (edge-list :reader edge-list :initarg edge-list) 8 - (point-ring :reader point-ring :initarg point-ring))) 6 + ((point-list :reader point-list :initarg :point-list) 7 + (edge-list :reader edge-list :initarg :edge-list) 8 + (point-ring :reader point-ring :initarg :point-ring))) 9 9 10 10 (defmethod print-object ((object polygon) stream) 11 11 (print-unreadable-object (object stream :type t :identity t) @@ -17,6 +17,9 @@ 17 17 :edge-list (edge-list-from-point-list point-list) 18 18 :point-ring (double-linked-ring-from-point-list point-list))) 19 19 20 +(defun make-polygon-from-coords (&rest coord-list) 21 + (make-polygon-from-point-list (apply #'coords-to-points coord-list))) 22 + 20 23 (defun make-polygon-from-point-ring (point-ring) 21 24 (let ((point-list (point-list-from-ring point-ring))) 22 25 (make-polygon-from-point-list point-list)))
15  polygon.lisp
 @@ -7,7 +7,7 @@ 7 7 (if (simple-polygon-sh-p polygon) 8 8 (list polygon) 9 9 (let ((ring-index (collect-ring-nodes 10 - (point-ring polygon)))) 10 + (double-linked-ring-from-point-list (point-list polygon))))) 11 11 (let ((ring-edges (edge-list-from-point-list ring-index 'taint-segment))) 12 12 (let ((in-points (bentley-ottmann ring-edges)) 13 13 (simple-polys nil)) @@ -15,7 +15,7 @@ 15 15 (let ((edge1 (edge1 tk)) 16 16 (edge2 (edge2 tk))) 17 17 (unless (or (taint edge1) 18 - (taint edge2));vertex surgery will invalidate edges 18 + (taint edge2)) ;vertex surgery will invalidate edges 19 19 (let ((in1 (start edge1)) 20 20 (out1 (end edge1)) 21 21 (in2 (start edge2)) @@ -39,11 +39,10 @@ 39 39 (iterate (while ring-index) 40 40 (push (collect-ring-nodes (car ring-index)) simple-polys) 41 41 (setf ring-index (set-difference ring-index (car simple-polys)))) 42 - (reduce #'append 43 - (mapcar #'decompose-complex-polygon-bentley-ottmann ;due to tainting the polygon might not have been completely decomposed 44 - (mapcar #'(lambda (poly) 45 - (mapcar #'val poly)) 46 - simple-polys)))))))) 42 + (mapcan #'decompose-complex-polygon-bentley-ottmann ;due to tainting the polygon might not have been completely decomposed 43 + (mapcar #'(lambda (poly) 44 + (make-polygon-from-point-list (mapcar #'val poly))) 45 + simple-polys))))))) 47 46 48 47 (defun simple-polygon-sh-p (polygon) 49 48 "Check if polygon is simple using Shamos-Hoey algorithm." @@ -72,7 +71,7 @@ 72 71 73 72 (defun decompose-complex-polygon-triangles (polygon &key (in-test 'point-in-polygon-winding-p)) 74 73 "Decomposes a complex polygon into triangles. Returns a list of triangles inside polygon according to :in-test, which is a function taking a point and a polygon." 75 - (let ((trapez (trapezoidize-edges (edge-list-from-point-list polygon)))) 74 + (let ((trapez (trapezoidize-edges (edge-list polygon)))) 76 75 (let ((triangles (trapezoids-to-triangles trapez))) 77 76 (remove-if-not #'(lambda (x) 78 77 (funcall in-test (triangle-center-point x) polygon))
200  test-geometry.lisp
 @@ -7,60 +7,89 @@ 7 7 8 8 (in-package :test-geometry) 9 9 10 +(defparameter *test-polygon* 11 + (make-polygon-from-coords 12 + 10 10 20 20 20 70 70 70 70 20) 13 + "Test concave polygon") 14 + 15 +(defparameter *test-polygon2* 16 + (make-polygon-from-coords 17 + 20 20 10 40 20 70 70 70 70 20) 18 + "Test convex polygon") 19 + 20 +(defparameter *test-polygon3* 21 + (make-polygon-from-coords 22 + 20 20 10 40 70 40 70 70) 23 + "Test small complex polygon") 24 + 25 +(defparameter *test-polygon4* 26 + (make-polygon-from-coords 27 + 20 20 10 30 70 15 70 40 30 35 50 10 45 35 25 60)) 28 + 10 29 (defun test-triangulate (polygon w h &optional (x 0) (y 0)) 11 - (with-canvas (:width w :height h) 12 - (translate x y) 13 - (set-rgb-fill 0 0 0.8) 14 - (move-to (x (car polygon))(y (car polygon))) 15 - (dolist (tk polygon) 16 - (line-to (x tk)(y tk))) 17 - (line-to (x (car polygon))(y (car polygon))) 18 - (fill-path) 19 - (set-rgb-stroke 0 1.0 0) 20 - (set-line-width 2) 21 - (set-line-join :bevel) 22 - (dolist (tk (triangulate polygon)) 23 - (move-to (x (car tk))(y (car tk))) 24 - (dolist (kk tk) 25 - (line-to (x kk)(y kk))) 26 - (line-to (x (car tk))(y (car tk)))) 27 - (stroke) 28 - (save-png "test-geometry.png"))) 30 + (let ((point-list (point-list polygon))) 31 + (with-canvas (:width w :height h) 32 + (translate x y) 33 + (set-rgb-fill 0 0 0.8) 34 + (move-to (x (car point-list))(y (car point-list))) 35 + (dolist (tk point-list) 36 + (line-to (x tk)(y tk))) 37 + (line-to (x (car point-list))(y (car point-list))) 38 + (fill-path) 39 + (set-rgb-stroke 0 1.0 0) 40 + (set-line-width 2) 41 + (set-line-join :bevel) 42 + (dolist (tk (triangulate polygon)) 43 + (let ((point-list (point-list tk))) 44 + (move-to (x (car point-list))(y (car point-list))) 45 + (dolist (kk (cdr point-list)) 46 + (line-to (x kk)(y kk))) 47 + (line-to (x (car point-list))(y (car point-list))) 48 + (stroke))) 49 + (save-png "test-geometry.png")))) 50 + 51 +;; (test-triangulate *test-polygon* 100 100) 52 +;; (test-triangulate *test-polygon2* 100 100) 29 53 30 54 (defun test-decompose (polygon w h &optional (x 0) (y 0)) 31 - (with-canvas (:width w :height h) 32 - (translate x y) 33 - (set-rgba-fill 0 0 0.8 1.0) 34 - (set-rgba-stroke 0 0.8 0 0.5) 35 - (move-to (x (car polygon))(y (car polygon))) 36 - (dolist (tk polygon) 37 - (line-to (x tk)(y tk))) 38 - (line-to (x (car polygon))(y (car polygon))) 39 - (fill-and-stroke) 40 - (let ((d-polys (decompose-complex-polygon-nondisjoint polygon))) 41 - (dolist (tk d-polys) 42 - (translate 100 0) 43 - (set-rgba-fill (random 1.0)(random 1.0)(random 1.0) 1.0) 44 - (move-to (x (car tk))(y (car tk))) 45 - (dolist (kk tk) 46 - (line-to (x kk)(y kk))) 47 - (line-to (x (car tk))(y (car tk))) 48 - (fill-path))) 49 - (save-png "test-geometry.png"))) 55 + (let ((point-list (point-list polygon))) 56 + (with-canvas (:width w :height h) 57 + (translate x y) 58 + (set-rgba-fill 0 0 0.8 1.0) 59 + (set-rgba-stroke 0 0.8 0 0.5) 60 + (move-to (x (car point-list))(y (car point-list))) 61 + (dolist (tk point-list) 62 + (line-to (x tk)(y tk))) 63 + (line-to (x (car point-list))(y (car point-list))) 64 + (fill-and-stroke) 65 + (let ((d-polys (decompose-complex-polygon-nondisjoint polygon))) 66 + (dolist (tk (mapcar #'point-list d-polys)) 67 + (translate 100 0) 68 + (set-rgba-fill (random 1.0)(random 1.0)(random 1.0) 1.0) 69 + (move-to (x (car tk))(y (car tk))) 70 + (dolist (kk (cdr tk)) 71 + (line-to (x kk)(y kk))) 72 + (line-to (x (car tk))(y (car tk))) 73 + (fill-path))) 74 + (save-png "test-geometry.png")))) 75 + 76 +;; (test-decompose *test-polygon3* 300 100) 77 +;; (test-decompose *test-polygon4* 400 100) 50 78 51 79 (defun test-bentley-ottmann (polygon) 52 80 (if (frustrated-polygon-p polygon) 53 81 'frustrated 54 - (let ((in-points (bentley-ottmann (geometry::edge-list-from-point-list polygon)))) 82 + (let ((in-points (bentley-ottmann (edge-list polygon))) 83 + (point-list (point-list polygon))) 55 84 (with-canvas (:width 400 :height 400) 56 85 (scale 4 4) 57 86 (set-rgb-stroke 0 0 1.0) 58 87 (set-line-width 1/5) 59 - (move-to (x (car polygon)) 60 - (y (car polygon))) 61 - (dolist (tk polygon) 88 + (move-to (x (car point-list)) 89 + (y (car point-list))) 90 + (dolist (tk (cdr point-list)) 62 91 (line-to (x tk)(y tk))) 63 - (line-to (x (car polygon))(y (car polygon))) 92 + (line-to (x (car point-list))(y (car point-list))) 64 93 (stroke) 65 94 (set-rgba-fill 0 1.0 0 0.4) 66 95 (dolist (tk in-points) @@ -74,44 +103,53 @@ 74 103 (fill-path)) 75 104 (save-png "test-geometry.png"))))) 76 105 106 +;; (test-bentley-ottmann *test-polygon3*) 107 +;; (test-bentley-ottmann *test-polygon4*) 108 + 77 109 (defun test-decompose-bo (polygon w h &optional (x 0) (y 0)) 78 - (with-canvas (:width w :height h) 79 - (translate x y) 80 - (set-rgba-fill 0 0 0.8 1.0) 81 - (set-rgba-stroke 0 0.8 0 0.5) 82 - (move-to (x (car polygon))(y (car polygon))) 83 - (dolist (tk polygon) 84 - (line-to (x tk)(y tk))) 85 - (line-to (x (car polygon))(y (car polygon))) 86 - (fill-and-stroke) 87 - (let ((d-polys (decompose-complex-polygon-bentley-ottmann polygon))) 88 - (dolist (tk d-polys) 89 - (translate 100 0) 90 - (set-rgba-fill (random 1.0)(random 1.0)(random 1.0) 1.0) 91 - (move-to (x (car tk))(y (car tk))) 92 - (dolist (kk tk) 93 - (line-to (x kk)(y kk))) 94 - (line-to (x (car tk))(y (car tk))) 95 - (fill-path))) 96 - (save-png "test-geometry.png"))) 110 + (let ((point-list (point-list polygon))) 111 + (with-canvas (:width w :height h) 112 + (translate x y) 113 + (set-rgba-fill 0 0 0.8 1.0) 114 + (set-rgba-stroke 0 0.8 0 0.5) 115 + (move-to (x (car point-list))(y (car point-list))) 116 + (dolist (tk (cdr point-list)) 117 + (line-to (x tk)(y tk))) 118 + (line-to (x (car point-list))(y (car point-list))) 119 + (fill-and-stroke) 120 + (let ((d-polys (decompose-complex-polygon-bentley-ottmann polygon))) 121 + (dolist (tk (mapcar #'point-list d-polys)) 122 + (translate 100 0) 123 + (set-rgba-fill (random 1.0)(random 1.0)(random 1.0) 1.0) 124 + (move-to (x (car tk))(y (car tk))) 125 + (dolist (kk (cdr tk)) 126 + (line-to (x kk)(y kk))) 127 + (line-to (x (car tk))(y (car tk))) 128 + (fill-path))) 129 + (save-png "test-geometry.png")))) 130 + 131 +;;(test-decompose-bo *test-polygon3* 300 100) 132 +;;(test-decompose-bo *test-polygon4* 400 100) 97 133 98 -(defun test-decompose-triangle (polygon) 99 - (with-canvas (:width 420 :height 420) 100 - (translate 10 10) 101 - (set-rgba-fill 0 0 0.8 1.0) 102 - (set-rgba-stroke 0 0.8 0 0.5) 103 - (move-to (x (car polygon))(y (car polygon))) 104 - (dolist (tk polygon) 105 - (line-to (x tk)(y tk))) 106 - (line-to (x (car polygon))(y (car polygon))) 107 - (even-odd-fill-and-stroke) 108 - (translate 0 0) 109 - (let ((d-polys (decompose-complex-polygon-triangles polygon :in-test 'geometry:point-in-polygon-crossing-p))) 110 - (set-rgba-fill 0 1.0 0 0.2) 111 - (dolist (tk d-polys) 112 - (move-to (x (car tk))(y (car tk))) 113 - (dolist (kk tk) 114 - (line-to (x kk)(y kk))) 115 - (line-to (x (car tk))(y (car tk))) 116 - (fill-and-stroke))) 117 - (save-png "test-geometry.png"))) 134 +(defun test-decompose-triangle (polygon w h) 135 + (let ((point-list (point-list polygon))) 136 + (with-canvas (:width w :height h) 137 + (translate 10 10) 138 + (set-rgba-fill 0 0 0.8 1.0) 139 + (set-rgba-stroke 0 0.8 0 0.5) 140 + (move-to (x (car point-list))(y (car point-list))) 141 + (dolist (tk (cdr point-list)) 142 + (line-to (x tk)(y tk))) 143 + (line-to (x (car point-list))(y (car point-list))) 144 + (even-odd-fill-and-stroke) 145 + (translate 0 0) 146 + (let ((d-polys (mapcar #'point-list 147 + (decompose-complex-polygon-triangles polygon :in-test 'geometry:point-in-polygon-crossing-p)))) 148 + (set-rgba-fill 0 1.0 0 0.2) 149 + (dolist (tk d-polys) 150 + (move-to (x (car tk))(y (car tk))) 151 + (dolist (kk tk) 152 + (line-to (x kk)(y kk))) 153 + (line-to (x (car tk))(y (car tk))) 154 + (fill-and-stroke))) 155 + (save-png "test-geometry.png"))))
20  trapezoidation.lisp
 @@ -67,20 +67,20 @@ 67 67 (line-from-segment prev-edge) 68 68 (make-instance 'line :a 1 :b 0 :c (- (x event))))))) 69 69 (push (coords-to-points 70 - (list (x sweep-line)(y (start prev-edge)) 71 - (x event) inters2-y 72 - (x event) inters1-y 73 - (x sweep-line)(y (start tk)))) 70 + (x sweep-line)(y (start prev-edge)) 71 + (x event) inters2-y 72 + (x event) inters1-y 73 + (x sweep-line)(y (start tk))) 74 74 trapezoids)) 75 75 (setf prev-edge tk))) 76 76 ;terminate with upper bounding edge 77 77 (push (coords-to-points 78 - (list (x sweep-line)(y (start prev-edge)) 79 - (x event)(y (lines-intersection-point 80 - (line-from-segment prev-edge) 81 - (make-instance 'line :a 1 :b 0 :c (- (x event))))) 82 - (x event) min-y 83 - (x sweep-line) min-y)) 78 + (x sweep-line)(y (start prev-edge)) 79 + (x event)(y (lines-intersection-point 80 + (line-from-segment prev-edge) 81 + (make-instance 'line :a 1 :b 0 :c (- (x event))))) 82 + (x event) min-y 83 + (x sweep-line) min-y) 84 84 trapezoids) 85 85 ;truncate edges 86 86 (trees:dotree (tk (edge-tree sweep-line))
13  triangulation.lisp
 @@ -26,7 +26,7 @@ 26 26 (left-on-p b a a-)))))) 27 27 28 28 (defun diagonal-p (ring-node-a ring-node-b) 29 - "Is a line segment between two nodes a diagonal of polygon with edges edge-list?" 29 + "Is a line segment between two nodes a diagonal of polygon the nodes belong to?" 30 30 (and (in-cone-p ring-node-a (val ring-node-b)) 31 31 (in-cone-p ring-node-b (val ring-node-a)) 32 32 (possible-diagonal-p (make-instance 'line-segment @@ -65,17 +65,24 @@ 65 65 66 66 (defun triangulate (polygon) 67 67 "Triangulate polygon. Returns list of triangles." 68 - (let ((point-list (point-list polygon))) 68 + (unless (simple-polygon-p polygon) 69 + (error "Polygon must be simple for ear-removal.")) 70 + (let ((point-list (if (plusp (polygon-orientation polygon)) 71 + (point-list polygon) 72 + (reverse (point-list polygon))))) 69 73 (let ((num-vertices (length point-list)) 70 74 (ear-list)) 71 75 (let ((ring-head (ear-init point-list))) 72 76 (iterate (while (> num-vertices 3)) 73 77 (with node = ring-head) 78 + (with counter = 0) 74 79 (if (ear node) 75 80 (multiple-value-bind (new-node ear) (remove-ear node) 76 81 (setf node new-node) 77 82 (decf num-vertices) 78 83 (push ear ear-list)) 79 84 (setf node (next-node node))) 85 + (assert (<= counter num-vertices)) 86 + (incf counter) 80 87 (finally (push (point-list-from-ring node) ear-list)))) 81 - (mapcar #'make-polygon-from-point-list ear-list)))) 88 + (mapcar #'make-polygon-from-point-list ear-list))))