@@ -19,6 +19,9 @@ "Create a new line segment." (make-instance line-segment-type :start start :end end)) +(defun copy-line-segment (line-segment) + (make-instance (type-of line-segment) :start (start line-segment) :end (end line-segment))) + (defclass line () ((A :accessor A :initarg :A) (B :accessor B :initarg :B) basic-line.lisp @@ -18,8 +18,7 @@ t) nil)) -(defun sanitize-edges (edge-list acc) - "Drop zero length edges and merge all segment intersecting edges." +(defun recurse-sanitize-edges (edge-list acc) (if (null edge-list) (nreverse acc) (let ((head (car edge-list)) @@ -33,11 +32,14 @@ (push tk racc))) (sanitize-edges racc (cons head acc))))))) +(defun sanitize-edges (edge-list) + "Drop zero length edges and merge all segment intersecting edges." + (recurse-sanitize-edges (mapcar #'copy-line-segment edge-list) nil)) + (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 polygon1) - (edge-list polygon2)) - nil))) + (edge-list polygon2))))) (let ((trapez (trapezoidize-edges edge-list))) (let ((triangles (trapezoids-to-triangles trapez))) (remove-if-not triangle-test triangles))))) @@ -76,7 +78,7 @@ (typecase poly (polygon t) (t nil))) - holes)))) nil))) + holes))))))) (let ((trapez (trapezoidize-edges edge-list))) (let ((triangles (trapezoids-to-triangles trapez))) (remove-if-not #'(lambda (x) polygon-binary.lisp aa69b658d43c0517c06965fb498a62492fce7f12 Ramarren ramarren@gmail.com http://github.com/Ramarren/cl-geometry/commit/9db5359e3db7217cf51142bb108eba8cdb86c910 9db5359e3db7217cf51142bb108eba8cdb86c910 2009-07-13T03:18:03-07:00 2009-07-13T03:18:03-07:00 Don't clobber polygon edge-lists. 8ed0ec16fd1e77e4abf8d34ec2dc52a9367b062b Ramarren ramarren@gmail.com