Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Change test to use polygon class and fix some things.

  • Loading branch information...
commit 30d0b81cc730baddcb543415c5bcaacd9552a87c 1 parent 3f94ed3
@Ramarren authored
View
15 basic-point.lisp
@@ -4,8 +4,8 @@
;;;; object) (y object).
(defclass point ()
- ((x :accessor x :initarg :x :initform 0)
- (y :accessor y :initarg :y :initform 0))
+ ((x :reader x :initarg :x :initform 0)
+ (y :reader y :initarg :y :initform 0))
(:documentation "A point on a plane, with cartesian coordinates."))
(defmethod print-object ((object point) stream)
@@ -21,16 +21,11 @@
(and (= (x point1)(x point2))
(= (y point1)(y point2))))
-(defun coords-to-points (coord-list)
+(defun coords-to-points (&rest coord-list)
"Coordinate list (x1 y1 x2 y2 ... xn yn) to point list"
(assert (zerop (mod (length coord-list) 2)))
- (labels ((recurse-list (coord-list acc)
- (if (null coord-list)
- (nreverse acc)
- (recurse-list (cddr coord-list)
- (cons (make-point (car coord-list) (cadr coord-list))
- acc)))))
- (recurse-list coord-list nil)))
+ (iterate (for (x y . nil) on coord-list by #'cddr)
+ (collect (make-point x y))))
(defun left-p (a b c)
"Is c to the left of the oriented line defined by a->b?"
View
8 bentley-ottmann.lisp
@@ -83,6 +83,14 @@
((edge-tree :accessor edge-tree))
(:documentation "Sweep line."))
+(defgeneric (setf x) (new-value object)
+ (:method (new-value (object sweep-line))
+ (setf (slot-value object 'x) new-value)))
+
+(defgeneric (setf y) (new-value object)
+ (:method (new-value (object sweep-line))
+ (setf (slot-value object 'y) new-value)))
+
(defmethod initialize-instance :after ((instance sweep-line) &rest initargs)
"Create a tree, use closure over the sweep line as ordering function."
(declare (ignore initargs))
View
6 cl-geometry-tests.asd
@@ -0,0 +1,6 @@
+(asdf:defsystem :cl-geometry-tests
+ :description "Tests for cl-geometry."
+ :version "0"
+ :licence "BSD"
+ :components ((:file "test-geometry"))
+ :depends-on (:cl-geometry :vecto :iterate))
View
2  decomposition.lisp
@@ -26,7 +26,7 @@
(defun decompose-complex-polygon-nondisjoint (polygon)
"Decomposes a complex polygon into a set of simple ones, possibly some entirely contained in others."
- (let ((ring-head (point-ring polygon))
+ (let ((ring-head (double-linked-ring-from-point-list (point-list polygon)))
(simple-polys nil))
(let ((ring-index (collect-ring-nodes ring-head))
(edge-list (ring-to-list-of-edges ring-head)))
View
10 package.lisp
@@ -23,6 +23,9 @@
#:end
#:line
#:A #:B #:C
+ #:polygon
+ #:point-list
+ #:edge-list
#:line-y-at-x #:line-x-at-y
#:line-from-segment
#:line-segment-length
@@ -49,4 +52,9 @@
#:decompose-complex-polygon-triangles
#:polygon-union
#:polygon-intersection
- #:polygon-difference))
+ #:polygon-difference
+ #:make-polygon-from-point-list
+ #:make-polygon-from-point-ring
+ #:coords-to-points
+ #:make-polygon-from-coords))
+
View
9 polygon-class.lisp
@@ -3,9 +3,9 @@
;;; Treat polygons as immutable object, construct all representations
(defclass polygon ()
- ((point-list :reader point-list :initarg point-list)
- (edge-list :reader edge-list :initarg edge-list)
- (point-ring :reader point-ring :initarg point-ring)))
+ ((point-list :reader point-list :initarg :point-list)
+ (edge-list :reader edge-list :initarg :edge-list)
+ (point-ring :reader point-ring :initarg :point-ring)))
(defmethod print-object ((object polygon) stream)
(print-unreadable-object (object stream :type t :identity t)
@@ -17,6 +17,9 @@
:edge-list (edge-list-from-point-list point-list)
:point-ring (double-linked-ring-from-point-list point-list)))
+(defun make-polygon-from-coords (&rest coord-list)
+ (make-polygon-from-point-list (apply #'coords-to-points coord-list)))
+
(defun make-polygon-from-point-ring (point-ring)
(let ((point-list (point-list-from-ring point-ring)))
(make-polygon-from-point-list point-list)))
View
15 polygon.lisp
@@ -7,7 +7,7 @@
(if (simple-polygon-sh-p polygon)
(list polygon)
(let ((ring-index (collect-ring-nodes
- (point-ring polygon))))
+ (double-linked-ring-from-point-list (point-list polygon)))))
(let ((ring-edges (edge-list-from-point-list ring-index 'taint-segment)))
(let ((in-points (bentley-ottmann ring-edges))
(simple-polys nil))
@@ -15,7 +15,7 @@
(let ((edge1 (edge1 tk))
(edge2 (edge2 tk)))
(unless (or (taint edge1)
- (taint edge2));vertex surgery will invalidate edges
+ (taint edge2)) ;vertex surgery will invalidate edges
(let ((in1 (start edge1))
(out1 (end edge1))
(in2 (start edge2))
@@ -39,11 +39,10 @@
(iterate (while ring-index)
(push (collect-ring-nodes (car ring-index)) simple-polys)
(setf ring-index (set-difference ring-index (car simple-polys))))
- (reduce #'append
- (mapcar #'decompose-complex-polygon-bentley-ottmann ;due to tainting the polygon might not have been completely decomposed
- (mapcar #'(lambda (poly)
- (mapcar #'val poly))
- simple-polys))))))))
+ (mapcan #'decompose-complex-polygon-bentley-ottmann ;due to tainting the polygon might not have been completely decomposed
+ (mapcar #'(lambda (poly)
+ (make-polygon-from-point-list (mapcar #'val poly)))
+ simple-polys)))))))
(defun simple-polygon-sh-p (polygon)
"Check if polygon is simple using Shamos-Hoey algorithm."
@@ -72,7 +71,7 @@
(defun decompose-complex-polygon-triangles (polygon &key (in-test 'point-in-polygon-winding-p))
"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."
- (let ((trapez (trapezoidize-edges (edge-list-from-point-list polygon))))
+ (let ((trapez (trapezoidize-edges (edge-list polygon))))
(let ((triangles (trapezoids-to-triangles trapez)))
(remove-if-not #'(lambda (x)
(funcall in-test (triangle-center-point x) polygon))
View
200 test-geometry.lisp
@@ -7,60 +7,89 @@
(in-package :test-geometry)
+(defparameter *test-polygon*
+ (make-polygon-from-coords
+ 10 10 20 20 20 70 70 70 70 20)
+ "Test concave polygon")
+
+(defparameter *test-polygon2*
+ (make-polygon-from-coords
+ 20 20 10 40 20 70 70 70 70 20)
+ "Test convex polygon")
+
+(defparameter *test-polygon3*
+ (make-polygon-from-coords
+ 20 20 10 40 70 40 70 70)
+ "Test small complex polygon")
+
+(defparameter *test-polygon4*
+ (make-polygon-from-coords
+ 20 20 10 30 70 15 70 40 30 35 50 10 45 35 25 60))
+
(defun test-triangulate (polygon w h &optional (x 0) (y 0))
- (with-canvas (:width w :height h)
- (translate x y)
- (set-rgb-fill 0 0 0.8)
- (move-to (x (car polygon))(y (car polygon)))
- (dolist (tk polygon)
- (line-to (x tk)(y tk)))
- (line-to (x (car polygon))(y (car polygon)))
- (fill-path)
- (set-rgb-stroke 0 1.0 0)
- (set-line-width 2)
- (set-line-join :bevel)
- (dolist (tk (triangulate polygon))
- (move-to (x (car tk))(y (car tk)))
- (dolist (kk tk)
- (line-to (x kk)(y kk)))
- (line-to (x (car tk))(y (car tk))))
- (stroke)
- (save-png "test-geometry.png")))
+ (let ((point-list (point-list polygon)))
+ (with-canvas (:width w :height h)
+ (translate x y)
+ (set-rgb-fill 0 0 0.8)
+ (move-to (x (car point-list))(y (car point-list)))
+ (dolist (tk point-list)
+ (line-to (x tk)(y tk)))
+ (line-to (x (car point-list))(y (car point-list)))
+ (fill-path)
+ (set-rgb-stroke 0 1.0 0)
+ (set-line-width 2)
+ (set-line-join :bevel)
+ (dolist (tk (triangulate polygon))
+ (let ((point-list (point-list tk)))
+ (move-to (x (car point-list))(y (car point-list)))
+ (dolist (kk (cdr point-list))
+ (line-to (x kk)(y kk)))
+ (line-to (x (car point-list))(y (car point-list)))
+ (stroke)))
+ (save-png "test-geometry.png"))))
+
+;; (test-triangulate *test-polygon* 100 100)
+;; (test-triangulate *test-polygon2* 100 100)
(defun test-decompose (polygon w h &optional (x 0) (y 0))
- (with-canvas (:width w :height h)
- (translate x y)
- (set-rgba-fill 0 0 0.8 1.0)
- (set-rgba-stroke 0 0.8 0 0.5)
- (move-to (x (car polygon))(y (car polygon)))
- (dolist (tk polygon)
- (line-to (x tk)(y tk)))
- (line-to (x (car polygon))(y (car polygon)))
- (fill-and-stroke)
- (let ((d-polys (decompose-complex-polygon-nondisjoint polygon)))
- (dolist (tk d-polys)
- (translate 100 0)
- (set-rgba-fill (random 1.0)(random 1.0)(random 1.0) 1.0)
- (move-to (x (car tk))(y (car tk)))
- (dolist (kk tk)
- (line-to (x kk)(y kk)))
- (line-to (x (car tk))(y (car tk)))
- (fill-path)))
- (save-png "test-geometry.png")))
+ (let ((point-list (point-list polygon)))
+ (with-canvas (:width w :height h)
+ (translate x y)
+ (set-rgba-fill 0 0 0.8 1.0)
+ (set-rgba-stroke 0 0.8 0 0.5)
+ (move-to (x (car point-list))(y (car point-list)))
+ (dolist (tk point-list)
+ (line-to (x tk)(y tk)))
+ (line-to (x (car point-list))(y (car point-list)))
+ (fill-and-stroke)
+ (let ((d-polys (decompose-complex-polygon-nondisjoint polygon)))
+ (dolist (tk (mapcar #'point-list d-polys))
+ (translate 100 0)
+ (set-rgba-fill (random 1.0)(random 1.0)(random 1.0) 1.0)
+ (move-to (x (car tk))(y (car tk)))
+ (dolist (kk (cdr tk))
+ (line-to (x kk)(y kk)))
+ (line-to (x (car tk))(y (car tk)))
+ (fill-path)))
+ (save-png "test-geometry.png"))))
+
+;; (test-decompose *test-polygon3* 300 100)
+;; (test-decompose *test-polygon4* 400 100)
(defun test-bentley-ottmann (polygon)
(if (frustrated-polygon-p polygon)
'frustrated
- (let ((in-points (bentley-ottmann (geometry::edge-list-from-point-list polygon))))
+ (let ((in-points (bentley-ottmann (edge-list polygon)))
+ (point-list (point-list polygon)))
(with-canvas (:width 400 :height 400)
(scale 4 4)
(set-rgb-stroke 0 0 1.0)
(set-line-width 1/5)
- (move-to (x (car polygon))
- (y (car polygon)))
- (dolist (tk polygon)
+ (move-to (x (car point-list))
+ (y (car point-list)))
+ (dolist (tk (cdr point-list))
(line-to (x tk)(y tk)))
- (line-to (x (car polygon))(y (car polygon)))
+ (line-to (x (car point-list))(y (car point-list)))
(stroke)
(set-rgba-fill 0 1.0 0 0.4)
(dolist (tk in-points)
@@ -74,44 +103,53 @@
(fill-path))
(save-png "test-geometry.png")))))
+;; (test-bentley-ottmann *test-polygon3*)
+;; (test-bentley-ottmann *test-polygon4*)
+
(defun test-decompose-bo (polygon w h &optional (x 0) (y 0))
- (with-canvas (:width w :height h)
- (translate x y)
- (set-rgba-fill 0 0 0.8 1.0)
- (set-rgba-stroke 0 0.8 0 0.5)
- (move-to (x (car polygon))(y (car polygon)))
- (dolist (tk polygon)
- (line-to (x tk)(y tk)))
- (line-to (x (car polygon))(y (car polygon)))
- (fill-and-stroke)
- (let ((d-polys (decompose-complex-polygon-bentley-ottmann polygon)))
- (dolist (tk d-polys)
- (translate 100 0)
- (set-rgba-fill (random 1.0)(random 1.0)(random 1.0) 1.0)
- (move-to (x (car tk))(y (car tk)))
- (dolist (kk tk)
- (line-to (x kk)(y kk)))
- (line-to (x (car tk))(y (car tk)))
- (fill-path)))
- (save-png "test-geometry.png")))
+ (let ((point-list (point-list polygon)))
+ (with-canvas (:width w :height h)
+ (translate x y)
+ (set-rgba-fill 0 0 0.8 1.0)
+ (set-rgba-stroke 0 0.8 0 0.5)
+ (move-to (x (car point-list))(y (car point-list)))
+ (dolist (tk (cdr point-list))
+ (line-to (x tk)(y tk)))
+ (line-to (x (car point-list))(y (car point-list)))
+ (fill-and-stroke)
+ (let ((d-polys (decompose-complex-polygon-bentley-ottmann polygon)))
+ (dolist (tk (mapcar #'point-list d-polys))
+ (translate 100 0)
+ (set-rgba-fill (random 1.0)(random 1.0)(random 1.0) 1.0)
+ (move-to (x (car tk))(y (car tk)))
+ (dolist (kk (cdr tk))
+ (line-to (x kk)(y kk)))
+ (line-to (x (car tk))(y (car tk)))
+ (fill-path)))
+ (save-png "test-geometry.png"))))
+
+;;(test-decompose-bo *test-polygon3* 300 100)
+;;(test-decompose-bo *test-polygon4* 400 100)
-(defun test-decompose-triangle (polygon)
- (with-canvas (:width 420 :height 420)
- (translate 10 10)
- (set-rgba-fill 0 0 0.8 1.0)
- (set-rgba-stroke 0 0.8 0 0.5)
- (move-to (x (car polygon))(y (car polygon)))
- (dolist (tk polygon)
- (line-to (x tk)(y tk)))
- (line-to (x (car polygon))(y (car polygon)))
- (even-odd-fill-and-stroke)
- (translate 0 0)
- (let ((d-polys (decompose-complex-polygon-triangles polygon :in-test 'geometry:point-in-polygon-crossing-p)))
- (set-rgba-fill 0 1.0 0 0.2)
- (dolist (tk d-polys)
- (move-to (x (car tk))(y (car tk)))
- (dolist (kk tk)
- (line-to (x kk)(y kk)))
- (line-to (x (car tk))(y (car tk)))
- (fill-and-stroke)))
- (save-png "test-geometry.png")))
+(defun test-decompose-triangle (polygon w h)
+ (let ((point-list (point-list polygon)))
+ (with-canvas (:width w :height h)
+ (translate 10 10)
+ (set-rgba-fill 0 0 0.8 1.0)
+ (set-rgba-stroke 0 0.8 0 0.5)
+ (move-to (x (car point-list))(y (car point-list)))
+ (dolist (tk (cdr point-list))
+ (line-to (x tk)(y tk)))
+ (line-to (x (car point-list))(y (car point-list)))
+ (even-odd-fill-and-stroke)
+ (translate 0 0)
+ (let ((d-polys (mapcar #'point-list
+ (decompose-complex-polygon-triangles polygon :in-test 'geometry:point-in-polygon-crossing-p))))
+ (set-rgba-fill 0 1.0 0 0.2)
+ (dolist (tk d-polys)
+ (move-to (x (car tk))(y (car tk)))
+ (dolist (kk tk)
+ (line-to (x kk)(y kk)))
+ (line-to (x (car tk))(y (car tk)))
+ (fill-and-stroke)))
+ (save-png "test-geometry.png"))))
View
20 trapezoidation.lisp
@@ -67,20 +67,20 @@
(line-from-segment prev-edge)
(make-instance 'line :a 1 :b 0 :c (- (x event)))))))
(push (coords-to-points
- (list (x sweep-line)(y (start prev-edge))
- (x event) inters2-y
- (x event) inters1-y
- (x sweep-line)(y (start tk))))
+ (x sweep-line)(y (start prev-edge))
+ (x event) inters2-y
+ (x event) inters1-y
+ (x sweep-line)(y (start tk)))
trapezoids))
(setf prev-edge tk)))
;terminate with upper bounding edge
(push (coords-to-points
- (list (x sweep-line)(y (start prev-edge))
- (x event)(y (lines-intersection-point
- (line-from-segment prev-edge)
- (make-instance 'line :a 1 :b 0 :c (- (x event)))))
- (x event) min-y
- (x sweep-line) min-y))
+ (x sweep-line)(y (start prev-edge))
+ (x event)(y (lines-intersection-point
+ (line-from-segment prev-edge)
+ (make-instance 'line :a 1 :b 0 :c (- (x event)))))
+ (x event) min-y
+ (x sweep-line) min-y)
trapezoids)
;truncate edges
(trees:dotree (tk (edge-tree sweep-line))
View
13 triangulation.lisp
@@ -26,7 +26,7 @@
(left-on-p b a a-))))))
(defun diagonal-p (ring-node-a ring-node-b)
- "Is a line segment between two nodes a diagonal of polygon with edges edge-list?"
+ "Is a line segment between two nodes a diagonal of polygon the nodes belong to?"
(and (in-cone-p ring-node-a (val ring-node-b))
(in-cone-p ring-node-b (val ring-node-a))
(possible-diagonal-p (make-instance 'line-segment
@@ -65,17 +65,24 @@
(defun triangulate (polygon)
"Triangulate polygon. Returns list of triangles."
- (let ((point-list (point-list polygon)))
+ (unless (simple-polygon-p polygon)
+ (error "Polygon must be simple for ear-removal."))
+ (let ((point-list (if (plusp (polygon-orientation polygon))
+ (point-list polygon)
+ (reverse (point-list polygon)))))
(let ((num-vertices (length point-list))
(ear-list))
(let ((ring-head (ear-init point-list)))
(iterate (while (> num-vertices 3))
(with node = ring-head)
+ (with counter = 0)
(if (ear node)
(multiple-value-bind (new-node ear) (remove-ear node)
(setf node new-node)
(decf num-vertices)
(push ear ear-list))
(setf node (next-node node)))
+ (assert (<= counter num-vertices))
+ (incf counter)
(finally (push (point-list-from-ring node) ear-list))))
- (mapcar #'make-polygon-from-point-list ear-list))))
+ (mapcar #'make-polygon-from-point-list ear-list))))
Please sign in to comment.
Something went wrong with that request. Please try again.