polygon.lisp

(in-package :2d-geometry)

;;;; This files contains top level polygon manipulating functions.

(defun decompose-complex-polygon-bentley-ottmann (polygon)
  "Decompose polygon using bentley-ottmann, hopefully in something close to quadratic time."
  (if (simple-polygon-sh-p polygon)
      (list polygon)
      (let ((ring-index (collect-ring-nodes
                         (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))
            (dolist (tk in-points)
              (let ((edge1 (edge1 tk))
                    (edge2 (edge2 tk)))
                (unless (or (taint edge1)
                            (taint edge2)) ;vertex surgery will invalidate edges
                  (let ((in1 (start edge1))
                        (out1 (end edge1))
                        (in2 (start edge2))
                        (out2 (end edge2)))
                    (let ((v1 (make-instance 'poly-ring-node
                                             :val tk
                                             :prev in1
                                             :next out2))
                          (v2 (make-instance 'poly-ring-node
                                             :val tk
                                             :prev in2
                                             :next out1)))
                      (push v1 ring-index)
                      (push v2 ring-index)
                      (setf (taint edge1) t
                            (taint edge2) t)
                      (setf (next-node in1) v1)
                      (setf (prev-node out1) v2)
                      (setf (next-node in2) v2)
                      (setf (prev-node out2) v1))))))
            (iterate (while ring-index)
                     (push (collect-ring-nodes (car ring-index)) simple-polys)
                     (setf ring-index (set-difference ring-index (car 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."
  (not (shamos-hoey (edge-list polygon))))

(defun trapezoids-to-triangles (trapez)
  "Convert list of trapezoids to list of triangles."
  (let ((triangles nil))
    (dolist (tk trapez)
      (let ((ctrap (collapse-trapezoid tk)))
        (cond
          ((= (length ctrap) 3)
           (push ctrap triangles))
          ((= (length ctrap) 4)
           (destructuring-bind (tr1 . tr2) (split-trapezoid ctrap)
             (push tr1 triangles)
             (push tr2 triangles))))))
    (mapcar #'make-polygon-from-point-list triangles)))

(defun triangle-center-point (triangle)
  "Return a central point of 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))))

(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 polygon))))
    (let ((triangles (trapezoids-to-triangles trapez)))
      (remove-if-not #'(lambda (x)
                         (funcall in-test (triangle-center-point x) polygon))
                     triangles))))