Browse files

Wrap polygon representations in a class, some cosmetic changes.

  • Loading branch information...
1 parent 7398125 commit 3f94ed34ce4284c416f4c3fb8be26a1dd3336966 @Ramarren committed Jul 13, 2009
Showing with 81 additions and 57 deletions.
  1. +21 −21 basic-polygon.lisp
  2. +8 −7 cl-geometry.asd
  3. +2 −2 decomposition.lisp
  4. +2 −2 polygon-binary.lisp
  5. +22 −0 polygon-class.lisp
  6. +4 −4 polygon.lisp
  7. +5 −5 representations.lisp
  8. +1 −1 trapezoidation.lisp
  9. +16 −15 triangulation.lisp
@@ -4,8 +4,8 @@
;;;; Express polygon a simple list of points.
-(defmethod construct-bounding-box ((object list));assumes all list are polygons...
- (iterate (for vertex in object)
+(defmethod construct-bounding-box ((object polygon))
+ (iterate (for vertex in (point-list object))
(minimizing (x vertex) into x-min)
(minimizing (y vertex) into y-min)
(maximizing (x vertex) into x-max)
@@ -16,35 +16,35 @@
:y-min y-min
:y-max y-max)))))
-(defun notany-symmetric-test (testfun lst)
- "Return t if test is nil for every combination of elements of lst, assuming test is symmetric."
- (labels ((recurse-list (lst1 lst2)
- (if (null lst1)
+(defun notany-symmetric-test (testfun list)
+ "Return t if test is nil for every combination of elements of list, assuming test is symmetric."
+ (labels ((recurse-list (list1 list2)
+ (if (null list1)
- (if (null lst2)
- (recurse-list (cdr lst1)(cddr lst1))
- (if (not (null (funcall testfun (car lst1) (car lst2))))
+ (if (null list2)
+ (recurse-list (cdr list1)(cddr list1))
+ (if (not (null (funcall testfun (car list1) (car list2))))
- (recurse-list lst1 (cdr lst2)))))))
- (recurse-list lst (cdr lst))))
+ (recurse-list list1 (cdr list2)))))))
+ (recurse-list list (cdr list))))
(defun frustrated-polygon-p (polygon)
"Check if there are any zero length edges or that any two colinear edges intersect."
- (let ((edge-list (edge-list-from-point-list polygon)))
+ (let ((edge-list (edge-list polygon)))
(or (some #'(lambda (e) (zerop (line-segment-length e))) edge-list)
(not (notany-symmetric-test #'line-segments-intersection-segment edge-list)))))
(defun simple-polygon-p (polygon)
"Check if polygon is simple, ie. if no two edges intersect, assuming only point intersections are possible. This uses brute force, comparing each edge to every other edge."
- (let ((edge-list (edge-list-from-point-list polygon)))
+ (let ((edge-list (edge-list polygon)))
(notany-symmetric-test #'(lambda (x y)
(line-segments-intersection-point x y :exclude-endpoints t))
(defun polygon-orientation (polygon)
"Return 1 if polygon is counterclockwise and -1 if it is oriented clockwise. Assumes simple polygon."
- (let ((poly-ring (double-linked-ring-from-point-list polygon)))
+ (let ((poly-ring (point-ring polygon)))
;find rightmost lowest vertex
(let ((lowest-rightmost-node (do ((node poly-ring (next-node node))
(min-node nil)
@@ -70,13 +70,13 @@
"Calculate an area of a simple polygon."
(* 1/2
(polygon-orientation polygon)
- (reduce #'+ (maplist #'(lambda (lst)
- (let ((v1 (car lst))
- (v2 (if (cdr lst)
- (cadr lst)
+ (reduce #'+ (maplist #'(lambda (list)
+ (let ((v1 (car list))
+ (v2 (if (cdr list)
+ (cadr list)
(car polygon))))
(- (* (x v1)(y v2))(* (x v2)(y v1)))))
- polygon))))
+ (point-list polygon)))))
(defun filter-ray-intersection (point edge)
"Return t if edge does not intersect ray from point properly."
@@ -92,14 +92,14 @@
(defun point-in-polygon-crossing-p (point polygon)
"Determine if a point belongs to a polygon using crossing (oddeven) rule."
- (let ((edge-list (edge-list-from-point-list polygon)))
+ (let ((edge-list (edge-list polygon)))
(oddp (count-if-not #'(lambda (edge)
(filter-ray-intersection point edge))
(defun point-in-polygon-winding-number (point polygon)
"Calculate winding number of a point."
- (let ((edge-list (edge-list-from-point-list polygon)))
+ (let ((edge-list (edge-list polygon)))
(let ((intersecting-edges (remove-if #'(lambda (edge)
(filter-ray-intersection point edge))
@@ -8,12 +8,13 @@
(:file "bounding-box" :depends-on ("package"))
(:file "basic-line" :depends-on ("bounding-box" "package"))
(:file "representations" :depends-on ("package" "basic-point" "basic-line"))
- (:file "basic-polygon" :depends-on ("basic-point" "representations" "basic-line"))
- (:file "triangulation" :depends-on ("basic-line" "trivial-geometry" "basic-polygon" "representations"))
- (:file "decomposition" :depends-on ("basic-line" "basic-polygon" "triangulation" "representations"))
+ (:file "polygon-class" :depends-on ("package" "representations"))
+ (:file "basic-polygon" :depends-on ("basic-point" "polygon-class" "basic-line"))
+ (:file "triangulation" :depends-on ("basic-line" "trivial-geometry" "basic-polygon" "representations" "polygon-class"))
+ (:file "decomposition" :depends-on ("basic-line" "basic-polygon" "triangulation" "representations" "polygon-class"))
(:file "heap")
- (:file "bentley-ottmann" :depends-on ("heap" "representations"))
- (:file "trapezoidation" :depends-on ("bentley-ottmann"))
- (:file "polygon" :depends-on ("basic-polygon" "triangulation" "decomposition" "trapezoidation"))
- (:file "polygon-binary" :depends-on ("polygon")))
+ (:file "bentley-ottmann" :depends-on ("heap" "representations" "polygon-class"))
+ (:file "trapezoidation" :depends-on ("bentley-ottmann" "polygon-class"))
+ (:file "polygon" :depends-on ("basic-polygon" "polygon-class" "triangulation" "decomposition" "trapezoidation"))
+ (:file "polygon-binary" :depends-on ("polygon" "polygon-class")))
:depends-on (:iterate :trees))
@@ -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 (double-linked-ring-from-point-list polygon))
+ (let ((ring-head (point-ring polygon))
(simple-polys nil))
(let ((ring-index (collect-ring-nodes ring-head))
(edge-list (ring-to-list-of-edges ring-head)))
@@ -70,4 +70,4 @@
(collect-ring-nodes ring-head)
:test #'point-equal-p))
(setf ring-head (car ring-index))))
- simple-polys))
+ (mapcar #'make-polygon-from-point-list simple-polys)))
@@ -35,8 +35,8 @@
(defun polygon-binary (polygon1 polygon2 triangle-test)
"Return all triangles fulfilling triangle-test from triangulation of all edges of two polygons."
- (let ((edge-list (sanitize-edges (append (edge-list-from-point-list polygon1)
- (edge-list-from-point-list polygon2))
+ (let ((edge-list (sanitize-edges (append (edge-list polygon1)
+ (edge-list polygon2))
(let ((trapez (trapezoidize-edges edge-list)))
(let ((triangles (trapezoids-to-triangles trapez)))
@@ -0,0 +1,22 @@
+(in-package :2d-geometry)
+;;; 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)))
+(defmethod print-object ((object polygon) stream)
+ (print-unreadable-object (object stream :type t :identity t)
+ (format stream "[~a]" (length (edge-list object)))))
+(defun make-polygon-from-point-list (point-list)
+ (make-instance 'polygon
+ :point-list (copy-seq point-list)
+ :edge-list (edge-list-from-point-list point-list)
+ :point-ring (double-linked-ring-from-point-list point-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)))
@@ -7,7 +7,7 @@
(if (simple-polygon-sh-p polygon)
(list polygon)
(let ((ring-index (collect-ring-nodes
- (double-linked-ring-from-point-list polygon))))
+ (point-ring polygon))))
(let ((ring-edges (edge-list-from-point-list ring-index 'taint-segment)))
(let ((in-points (bentley-ottmann ring-edges))
(simple-polys nil))
@@ -47,7 +47,7 @@
(defun simple-polygon-sh-p (polygon)
"Check if polygon is simple using Shamos-Hoey algorithm."
- (not (shamos-hoey (edge-list-from-point-list polygon))))
+ (not (shamos-hoey (edge-list polygon))))
(defun trapezoids-to-triangles (trapez)
"Convert list of trapezoids to list of triangles."
@@ -61,11 +61,11 @@
(destructuring-bind (tr1 . tr2) (split-trapezoid ctrap)
(push tr1 triangles)
(push tr2 triangles))))))
- triangles))
+ (mapcar #'make-polygon-from-point-list triangles)))
(defun triangle-center-point (triangle)
"Return a central point of triangle."
- (destructuring-bind (a b c) triangle
+ (destructuring-bind (a b c) (point-list triangle)
(make-instance 'point
:x (/ (+ (x a)(x b)(x c)) 3)
:y (/ (+ (y a)(y b)(y c)) 3))))
@@ -2,14 +2,14 @@
;;;; This file defines functions manipulating representation of geometric data.
-(defun edge-list-from-point-list (polygon &optional (edge-type 'line-segment))
+(defun edge-list-from-point-list (point-list &optional (edge-type 'line-segment))
"Change polygon represented as a list of points into a list of edges (line segments)."
- (let ((vertex-zero (car polygon)))
+ (let ((vertex-zero (car point-list)))
(maplist #'(lambda (lst)
(if (null (cadr lst))
(make-instance edge-type :start (car lst) :end vertex-zero)
(make-instance edge-type :start (car lst) :end (cadr lst))))
- polygon)))
+ point-list)))
(defclass poly-ring-node ()
((val :accessor val :initarg :val)
@@ -27,11 +27,11 @@
(defmethod y ((object poly-ring-node))
(y (val object)))
-(defun double-linked-ring-from-point-list (polygon &optional (ring-type 'poly-ring-node))
+(defun double-linked-ring-from-point-list (point-list &optional (ring-type 'poly-ring-node))
"Change polygon representation from list of points to double linked ring of points."
(let ((head (make-instance ring-type)))
(let ((tail head))
- (dolist (tk polygon)
+ (dolist (tk point-list)
(setf (val tail) tk
(next-node tail) (make-instance ring-type)
(prev-node (next-node tail)) tail
@@ -4,7 +4,7 @@
;;;; decomposing them into simple, disjoint polygons (trapezoids, which can be joined back into
;;;; larger polygons if desired, albeit slowly).
-;;;; This is somewhat different that trapezoidation for efficient triangulation, but it may be possible to
+;;;; This is somewhat different than trapezoidation for efficient triangulation, but it may be possible to
;;;; modify this code to do that. That is, it will work, but it may or may be not faster than ear removal.
(defun orient-edge-right (edge)
@@ -39,9 +39,9 @@
((ear :accessor ear :initarg :ear))
(:documentation "Ring node with ear information."))
-(defun ear-init (polygon)
+(defun ear-init (point-list)
"Takes a list of points and creates a ring initialized with ear data."
- (let ((ring-head (double-linked-ring-from-point-list polygon 'ear-ring-node)))
+ (let ((ring-head (double-linked-ring-from-point-list point-list 'ear-ring-node)))
(iterate (for node initially ring-head then (next-node node))
(until (and (eq node ring-head)
(not (first-iteration-p))))
@@ -65,16 +65,17 @@
(defun triangulate (polygon)
"Triangulate polygon. Returns list of triangles."
- (let ((num-vertices (length polygon))
- (ear-list))
- (let ((ring-head (ear-init polygon)))
- (iterate (while (> num-vertices 3))
- (with node = ring-head)
- (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)))
- (finally (push (point-list-from-ring node) ear-list))))
- ear-list))
+ (let ((point-list (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)
+ (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)))
+ (finally (push (point-list-from-ring node) ear-list))))
+ (mapcar #'make-polygon-from-point-list ear-list))))

0 comments on commit 3f94ed3

Please sign in to comment.