cl-geometry-tests.asd @@ -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?" basic-point.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)) bentley-ottmann.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))) decomposition.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)) + package.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))) polygon-class.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)) polygon.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")))) test-geometry.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)) trapezoidation.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)))) \ No newline at end of file + (mapcar #'make-polygon-from-point-list ear-list)))) triangulation.lisp 3f94ed34ce4284c416f4c3fb8be26a1dd3336966 Ramarren ramarren@gmail.com http://github.com/Ramarren/cl-geometry/commit/30d0b81cc730baddcb543415c5bcaacd9552a87c 30d0b81cc730baddcb543415c5bcaacd9552a87c 2009-07-13T01:26:38-07:00 2009-07-13T01:26:38-07:00 Change test to use polygon class and fix some things. cde3a73fb871beff7ccb58aef2025461a3888c75 Ramarren ramarren@gmail.com