From c4c397e12ff6fd6221f7b32575e7d4dc7c350f75 Mon Sep 17 00:00:00 2001 From: hasufell Date: Sat, 25 Oct 2014 20:23:34 +0200 Subject: [PATCH] POLYINT: small refactor, abstract some stuff out --- Algorithms/PolygonIntersection/Core.hs | 97 ++++++++++++-------------- 1 file changed, 43 insertions(+), 54 deletions(-) diff --git a/Algorithms/PolygonIntersection/Core.hs b/Algorithms/PolygonIntersection/Core.hs index cc84def..a54728a 100644 --- a/Algorithms/PolygonIntersection/Core.hs +++ b/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.empty + | Q.null pA && Q.null pB = 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 - (go (maybeShift . snd . Q.popFront $ pA) pB) - (PolyA (fromJust . Q.first $ pA) - (pre' pA' pA) - (suc' pA' pA)) - + = Q.pushFront (go (maybeShift . snd . Q.popFront $ pA) pB) + (mkPolyPT PolyA pA' pA) -- Same as above, except that the current point of polygon B -- is higher. - | otherwise - = Q.pushFront - (go pA (maybeShift . snd . Q.popFront $ pB)) - (PolyB (fromJust . Q.first $ pB) - (pre' pB' pB) - (suc' pB' pB)) + | otherwise = Q.pushFront (go pA (maybeShift . snd . Q.popFront $ pB)) + (mkPolyPT PolyB pB' pB) - pre' xs = fromJust . polySuccessor xs . uQfirst - suc' xs = fromJust . polyPredecessor xs . uQfirst + mkPolyPT f xs qs = f (fromJust . Q.first $ qs) + (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 - Nothing -> Nothing - Just index' -> if index' == (length pts - 1) - then pts `atMay` 0 - else pts `atMay` (index' + 1) - where - index = elemIndex pt pts +polySuccessor pts = polyPreSucInternal (length pts - 1, 0, 1) 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 - then pts `atMay` (length pts - 1) - else pts `atMay` (index' - 1) + Just index' -> if index' == i1 + then pts `atMay` i2 + 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 - . (++) (segIntersections . scanLine $ xs') - $ intersectionPoints (tail xs') + rmdups $ + (++) (segIntersections . scanLine $ 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),