POLYINT: small refactor, abstract some stuff out
This commit is contained in:
parent
b67ef899c7
commit
c4c397e12f
@ -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).
|
||||
@ -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),
|
||||
|
||||
Loading…
Reference in New Issue
Block a user