POLYINT: small refactor, abstract some stuff out

Algorithms/PolygonIntersection/Core.hs

@@ -3,6 +3,7 @@ module Algorithms.PolygonIntersection.Core where
 
 import           Algebra.Vector
 import           Algebra.VectorTypes
+import           Control.Applicative
 import           Data.Dequeue (BankersDequeue)
 import qualified Data.Dequeue           as Q
 import           Data.List
@@ -30,6 +31,15 @@ data PolyPT =
   deriving (Show, Eq)
 
 
+isPolyA :: PolyPT -> Bool
+isPolyA PolyA {} = True
+isPolyA _        = False
+
+
+isPolyB :: PolyPT -> Bool
+isPolyB = not . isPolyA
+
+
 -- |Shift a list of sorted convex hull points of a polygon so that
 -- the first element in the list is the one with the highest y-coordinate.
 -- This is done in O(n).
@@ -39,7 +49,7 @@ sortLexPoly ps = maybe [] (`shiftM` ps) (elemIndex (yMax ps) ps)
     yMax       = foldl1 (\x y -> if ptCmpY x y == GT then x else y)
 
 
--- | Sort the points of two polygons according to their y-coordinates,
+-- |Sort the points of two polygons according to their y-coordinates,
 -- while saving the origin of that point. This is done in O(n).
 sortLexPolys :: ([PT], [PT]) -> [PolyPT]
 sortLexPolys (pA'@(_:_), pB'@(_:_)) =
@@ -53,37 +63,29 @@ sortLexPolys (pA'@(_:_), pB'@(_:_)) =
     go :: BankersDequeue PT -> BankersDequeue PT -> BankersDequeue PolyPT
     go pA pB
       -- Nothing to sort.
-      | Q.null pA && Q.null pB
+      | Q.null pA && Q.null pB = Q.empty
-        = Q.empty
       -- Current point of polygon A is higher on the y-axis than the
       -- current point of polygon B, so insert it into the resulting
       -- queue and traverse the rest.
-      -- remark: we don't handle y1 = y2
       | ptCmpY (fromMaybe negInfPT . Q.first $ pA)
                (fromMaybe posInfPT . Q.first $ pB) == GT
-        = Q.pushFront
+        = Q.pushFront (go (maybeShift . snd . Q.popFront $ pA) pB)
-            (go (maybeShift . snd . Q.popFront $ pA) pB)
+                      (mkPolyPT PolyA pA' pA)
-            (PolyA (fromJust . Q.first $ pA)
-              (pre' pA' pA)
-              (suc' pA' pA))
-
       -- Same as above, except that the current point of polygon B
       -- is higher.
-      | otherwise
+      | otherwise = Q.pushFront (go pA (maybeShift . snd . Q.popFront $ pB))
-        = Q.pushFront
+                                (mkPolyPT PolyB pB' pB)
-            (go pA (maybeShift . snd . Q.popFront $ pB))
-            (PolyB (fromJust . Q.first $ pB)
-              (pre' pB' pB)
-              (suc' pB' pB))
 
-    pre' xs = fromJust . polySuccessor xs . uQfirst
+    mkPolyPT f xs qs = f (fromJust . Q.first $ qs)
-    suc' xs = fromJust . polyPredecessor xs . uQfirst
+                         (getPT' polySuccessor xs qs)
+                         (getPT' polyPredecessor xs qs)
+      where
+        getPT' f' xs' = fromJust . f' xs' . uQfirst
 
     -- Compare the first and the last element of the queue according
     -- to their y-coordinate and shift the queue (if necessary) so that
     -- the element with the highest value is at the front.
     maybeShift :: BankersDequeue PT -> BankersDequeue PT
-    -- remark: we don't handle y1 = y2
     maybeShift q = if ptCmpY (fromMaybe posInfPT . Q.first $ q)
                              (fromMaybe negInfPT . Q.last  $ q) == GT
                      then q
@@ -95,24 +97,23 @@ sortLexPolys _ = []
 -- Returns Nothing if the point is not on the convex hull. This
 -- is done in O(n).
 polySuccessor :: [PT] -> PT -> Maybe PT
-polySuccessor pts pt = case index of
+polySuccessor pts = polyPreSucInternal (length pts - 1, 0, 1) pts
-  Nothing      -> Nothing
-  Just index'  -> if index' == (length pts - 1)
-                    then pts `atMay` 0
-                    else pts `atMay` (index' + 1)
-  where
-    index = elemIndex pt pts
 
 
 -- |Get the predecessor of a point on a convex hull of a polygon.
 -- Returns Nothing if the point is not on the convex hull. This
 -- is done in O(n).
 polyPredecessor :: [PT] -> PT -> Maybe PT
-polyPredecessor pts pt = case index of
+polyPredecessor pts = polyPreSucInternal (0, length pts - 1, negate 1) pts
+
+
+-- |Abstraction for polyPredecessor and polySuccessor.
+polyPreSucInternal :: (Int, Int, Int) -> [PT] -> PT -> Maybe PT
+polyPreSucInternal (i1, i2, i3) pts pt = case index of
   Nothing     -> Nothing
-  Just index' -> if index' == 0
+  Just index' -> if index' == i1
-                   then pts `atMay` (length pts - 1)
+                   then pts `atMay` i2
-                   else pts `atMay` (index' - 1)
+                   else pts `atMay` (index' + i3)
   where
     index = elemIndex pt pts
 
@@ -122,14 +123,22 @@ polyPredecessor pts pt = case index of
 intersectionPoints :: [PolyPT] -> [PT]
 intersectionPoints []  = []
 intersectionPoints xs' =
-  rmdups
+  rmdups $
-    . (++) (segIntersections . scanLine $ xs')
+    (++) (segIntersections . scanLine $ xs')
-    $ intersectionPoints (tail xs')
+         (intersectionPoints (tail xs'))
   where
     -- Get the scan line or in other words the
     -- Segment pairs we are going to check for intersection.
     scanLine :: [PolyPT] -> ([Segment], [Segment])
-    scanLine xs = (segmentsA xs, sgementsB xs)
+    scanLine sp@(_:_) =
+      (,)
+        (getSegment isPolyA)
+        (getSegment isPolyB)
+      where
+        getSegment f = fromMaybe []
+                                 ((\x -> [(id' x, suc x), (id' x, pre x)])
+                                   <$> (listToMaybe . filter f $ sp))
+    scanLine _ = ([], [])
 
     -- Gets the actual intersections between the segments of
     -- both polygons we currently examine. This is done in O(1)
@@ -146,26 +155,6 @@ intersectionPoints xs' =
     combinations :: [a] -> [a] -> [[a]]
     combinations xs ys = concat . fmap (\y -> fmap (\x -> [y, x]) xs) $ ys
 
-    segmentsA :: [PolyPT] -> [Segment]
-    segmentsA sp@(_:_) = case a of
-      Nothing -> []
-      Just x  -> [(id' x, suc x), (id' x, pre x)]
-      where
-        a = listToMaybe . filter (\x -> case x of
-                                           PolyA {} -> True
-                                           _       -> False) $ sp
-    segmentsA _ = []
-
-    sgementsB :: [PolyPT] -> [Segment]
-    sgementsB sp@(_:_) = case b of
-      Nothing -> []
-      Just x  -> [(id' x, suc x), (id' x, pre x)]
-      where
-        b = listToMaybe . filter (\x -> case x of
-                                           PolyB {} -> True
-                                           _       -> False) $ sp
-    sgementsB _ = []
-
 
 testArr :: ([PT], [PT])
 testArr = ([p2 (200.0, 500.0),