(in-package :2d-geometry)
;;;; This file implements union, intersection and difference of polygons using triangulation of edge sets.
(defun merge-line-segment-into (ls1 ls2)
"If two segments are colinear and intersect, extends the first one to include the second. Reorients the first edge to the left."
(if (line-segments-intersection-segment ls1 ls2)
(let ((left-ls1 (left-endpoint ls1))
(left-ls2 (left-endpoint ls2))
(right-ls1 (right-endpoint ls1))
(right-ls2 (right-endpoint ls2)))
(setf (start ls1) (if (point-sort-fun left-ls1 left-ls2)
left-ls1
left-ls2)
(end ls1) (if (point-sort-fun right-ls1 right-ls2)
right-ls2
right-ls1))
t)
nil))
(defun recurse-sanitize-edges (edge-list acc)
(if (null edge-list)
(nreverse acc)
(let ((head (car edge-list))
(rst (cdr edge-list))
(racc nil))
(if (point-equal-p (start head) (end head))
(sanitize-edges rst acc)
(progn
(dolist (tk rst)
(unless (merge-line-segment-into head tk)
(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)))))
(let ((trapez (trapezoidize-edges edge-list)))
(let ((triangles (trapezoids-to-triangles trapez)))
(remove-if-not triangle-test triangles)))))
(defun polygon-union (polygon1 polygon2 &key (in-test 'point-in-polygon-winding-p) (in-test-1 nil) (in-test-2 nil))
"Return triangles of an union of two polygons."
(let ((in-1 (if in-test-1 in-test-1 in-test))
(in-2 (if in-test-2 in-test-2 in-test)))
(polygon-binary polygon1 polygon2 #'(lambda (x)
(or (funcall in-1 (triangle-center-point x) polygon1)
(funcall in-2 (triangle-center-point x) polygon2))))))
(defun polygon-intersection (polygon1 polygon2 &key (in-test 'point-in-polygon-winding-p) (in-test-1 nil) (in-test-2 nil))
"Return triangles of an intersection of two polygons."
(let ((in-1 (if in-test-1 in-test-1 in-test))
(in-2 (if in-test-2 in-test-2 in-test)))
(polygon-binary polygon1 polygon2 #'(lambda (x)
(and (funcall in-1 (triangle-center-point x) polygon1)
(funcall in-2 (triangle-center-point x) polygon2))))))
(defun polygon-difference (polygon1 polygon2 &key (in-test 'point-in-polygon-winding-p) (in-test-1 nil) (in-test-2 nil))
"Return triangles of polygon1 minus polygon2."
(let ((in-1 (if in-test-1 in-test-1 in-test))
(in-2 (if in-test-2 in-test-2 in-test)))
(polygon-binary polygon1 polygon2 #'(lambda (x)
(and (funcall in-1 (triangle-center-point x) polygon1)
(not (funcall in-2 (triangle-center-point x) polygon2)))))))
(defun polygon-difference-nary (polygon &rest holes &key (in-test 'point-in-polygon-winding-p))
"Return triangles of polygon with some holes."
(let ((edge-list (sanitize-edges (append (edge-list polygon)
(reduce #'append
(mapcar #'edge-list
(remove-if-not
#'(lambda (poly)
(typecase poly
(polygon t)
(t nil)))
holes)))))))
(let ((trapez (trapezoidize-edges edge-list)))
(let ((triangles (trapezoids-to-triangles trapez)))
(remove-if-not #'(lambda (x)
(let ((center-point (triangle-center-point x)))
(and (funcall in-test center-point polygon)
(every #'(lambda (hole)
(not (funcall in-test center-point hole)))
holes))))
triangles)))))
