# Ramarren/cl-geometry

Wrap polygon representations in a class, some cosmetic changes.

1 parent 7398125 commit 3f94ed34ce4284c416f4c3fb8be26a1dd3336966 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) t - (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)))) nil - (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)) edge-list))) (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)) edge-list)))) (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)) edge-list)))
 @@ -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)) nil))) (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))))