-- | __INTERNAL MODULE__, not exposed from the package.
module Geometry.Algorithms.Clipping.Internal (
      cutLineWithLine
    , CutLine(..)
    , cutPolygon

    , LineType(..)
    , clipPolygonWithLine
    , clipPolygonWithLineSegment
) where


import           Data.List
import           Data.Map   (Map)
import qualified Data.Map   as M
import           Data.Maybe
import           Data.Ord
import           Data.Set   (Set)
import qualified Data.Set   as S

import Geometry.Core
import Util



-- | Directed graph from each vertex to the next, so that following the chain of
-- pointers allows reconstruction of certain properties. Subdividing polygons is
-- done by finding minimal cycles, for example.
newtype EdgeGraph = EdgeGraph (Map Vec2 (Set Vec2))
    deriving (EdgeGraph -> EdgeGraph -> Bool
(EdgeGraph -> EdgeGraph -> Bool)
-> (EdgeGraph -> EdgeGraph -> Bool) -> Eq EdgeGraph
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeGraph -> EdgeGraph -> Bool
== :: EdgeGraph -> EdgeGraph -> Bool
$c/= :: EdgeGraph -> EdgeGraph -> Bool
/= :: EdgeGraph -> EdgeGraph -> Bool
Eq, Eq EdgeGraph
Eq EdgeGraph
-> (EdgeGraph -> EdgeGraph -> Ordering)
-> (EdgeGraph -> EdgeGraph -> Bool)
-> (EdgeGraph -> EdgeGraph -> Bool)
-> (EdgeGraph -> EdgeGraph -> Bool)
-> (EdgeGraph -> EdgeGraph -> Bool)
-> (EdgeGraph -> EdgeGraph -> EdgeGraph)
-> (EdgeGraph -> EdgeGraph -> EdgeGraph)
-> Ord EdgeGraph
EdgeGraph -> EdgeGraph -> Bool
EdgeGraph -> EdgeGraph -> Ordering
EdgeGraph -> EdgeGraph -> EdgeGraph
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: EdgeGraph -> EdgeGraph -> Ordering
compare :: EdgeGraph -> EdgeGraph -> Ordering
$c< :: EdgeGraph -> EdgeGraph -> Bool
< :: EdgeGraph -> EdgeGraph -> Bool
$c<= :: EdgeGraph -> EdgeGraph -> Bool
<= :: EdgeGraph -> EdgeGraph -> Bool
$c> :: EdgeGraph -> EdgeGraph -> Bool
> :: EdgeGraph -> EdgeGraph -> Bool
$c>= :: EdgeGraph -> EdgeGraph -> Bool
>= :: EdgeGraph -> EdgeGraph -> Bool
$cmax :: EdgeGraph -> EdgeGraph -> EdgeGraph
max :: EdgeGraph -> EdgeGraph -> EdgeGraph
$cmin :: EdgeGraph -> EdgeGraph -> EdgeGraph
min :: EdgeGraph -> EdgeGraph -> EdgeGraph
Ord)

instance Show EdgeGraph where
    show :: EdgeGraph -> String
show (EdgeGraph Map Vec2 (Set Vec2)
m) = [String] -> String
unlines
        (String
"EdgeGraph" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String
"    " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Vec2 -> String
forall a. Show a => a -> String
show Vec2
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" --> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set Vec2 -> String
forall a. Show a => a -> String
show Set Vec2
v | (Vec2
k,Set Vec2
v) <- Map Vec2 (Set Vec2) -> [(Vec2, Set Vec2)]
forall k a. Map k a -> [(k, a)]
M.toList Map Vec2 (Set Vec2)
m])

instance Semigroup EdgeGraph where
    EdgeGraph Map Vec2 (Set Vec2)
g1 <> :: EdgeGraph -> EdgeGraph -> EdgeGraph
<> EdgeGraph Map Vec2 (Set Vec2)
g2 = Map Vec2 (Set Vec2) -> EdgeGraph
EdgeGraph ((Set Vec2 -> Set Vec2 -> Set Vec2)
-> Map Vec2 (Set Vec2)
-> Map Vec2 (Set Vec2)
-> Map Vec2 (Set Vec2)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Set Vec2 -> Set Vec2 -> Set Vec2
forall a. Semigroup a => a -> a -> a
(<>) Map Vec2 (Set Vec2)
g1 Map Vec2 (Set Vec2)
g2)

instance Monoid EdgeGraph where
    mempty :: EdgeGraph
mempty = Map Vec2 (Set Vec2) -> EdgeGraph
EdgeGraph Map Vec2 (Set Vec2)
forall a. Monoid a => a
mempty

-- | An edge to be inserted into an EdgeGraph. Technically just a 'Line', but local
-- to the module so it can easily be extended by edge labels.
data Edge = Edge Vec2 Vec2
    deriving (Edge -> Edge -> Bool
(Edge -> Edge -> Bool) -> (Edge -> Edge -> Bool) -> Eq Edge
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Edge -> Edge -> Bool
== :: Edge -> Edge -> Bool
$c/= :: Edge -> Edge -> Bool
/= :: Edge -> Edge -> Bool
Eq, Eq Edge
Eq Edge
-> (Edge -> Edge -> Ordering)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Edge)
-> (Edge -> Edge -> Edge)
-> Ord Edge
Edge -> Edge -> Bool
Edge -> Edge -> Ordering
Edge -> Edge -> Edge
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Edge -> Edge -> Ordering
compare :: Edge -> Edge -> Ordering
$c< :: Edge -> Edge -> Bool
< :: Edge -> Edge -> Bool
$c<= :: Edge -> Edge -> Bool
<= :: Edge -> Edge -> Bool
$c> :: Edge -> Edge -> Bool
> :: Edge -> Edge -> Bool
$c>= :: Edge -> Edge -> Bool
>= :: Edge -> Edge -> Bool
$cmax :: Edge -> Edge -> Edge
max :: Edge -> Edge -> Edge
$cmin :: Edge -> Edge -> Edge
min :: Edge -> Edge -> Edge
Ord, Int -> Edge -> ShowS
[Edge] -> ShowS
Edge -> String
(Int -> Edge -> ShowS)
-> (Edge -> String) -> ([Edge] -> ShowS) -> Show Edge
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Edge -> ShowS
showsPrec :: Int -> Edge -> ShowS
$cshow :: Edge -> String
show :: Edge -> String
$cshowList :: [Edge] -> ShowS
showList :: [Edge] -> ShowS
Show)

-- | Pretty synonym for 'Edge'.
(-->) :: Vec2 -> Vec2 -> Edge
--> :: Vec2 -> Vec2 -> Edge
(-->) = Vec2 -> Vec2 -> Edge
Edge

data CutLine
    = NoCut Vec2 Vec2
        -- ^ (start, end). No cut has occurred, i.e. the cutting line did not
        -- intersect with the object.
    | Cut Vec2 Vec2 Vec2
        -- ^ (start, cut, end). The input was divided in two lines.
    deriving (CutLine -> CutLine -> Bool
(CutLine -> CutLine -> Bool)
-> (CutLine -> CutLine -> Bool) -> Eq CutLine
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CutLine -> CutLine -> Bool
== :: CutLine -> CutLine -> Bool
$c/= :: CutLine -> CutLine -> Bool
/= :: CutLine -> CutLine -> Bool
Eq, Eq CutLine
Eq CutLine
-> (CutLine -> CutLine -> Ordering)
-> (CutLine -> CutLine -> Bool)
-> (CutLine -> CutLine -> Bool)
-> (CutLine -> CutLine -> Bool)
-> (CutLine -> CutLine -> Bool)
-> (CutLine -> CutLine -> CutLine)
-> (CutLine -> CutLine -> CutLine)
-> Ord CutLine
CutLine -> CutLine -> Bool
CutLine -> CutLine -> Ordering
CutLine -> CutLine -> CutLine
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CutLine -> CutLine -> Ordering
compare :: CutLine -> CutLine -> Ordering
$c< :: CutLine -> CutLine -> Bool
< :: CutLine -> CutLine -> Bool
$c<= :: CutLine -> CutLine -> Bool
<= :: CutLine -> CutLine -> Bool
$c> :: CutLine -> CutLine -> Bool
> :: CutLine -> CutLine -> Bool
$c>= :: CutLine -> CutLine -> Bool
>= :: CutLine -> CutLine -> Bool
$cmax :: CutLine -> CutLine -> CutLine
max :: CutLine -> CutLine -> CutLine
$cmin :: CutLine -> CutLine -> CutLine
min :: CutLine -> CutLine -> CutLine
Ord, Int -> CutLine -> ShowS
[CutLine] -> ShowS
CutLine -> String
(Int -> CutLine -> ShowS)
-> (CutLine -> String) -> ([CutLine] -> ShowS) -> Show CutLine
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CutLine -> ShowS
showsPrec :: Int -> CutLine -> ShowS
$cshow :: CutLine -> String
show :: CutLine -> String
$cshowList :: [CutLine] -> ShowS
showList :: [CutLine] -> ShowS
Show)

data NormalizedCut
    = Entering Vec2
    | Exiting Vec2
    | Touching Vec2
    | AlongEdge Vec2 Vec2
    deriving (NormalizedCut -> NormalizedCut -> Bool
(NormalizedCut -> NormalizedCut -> Bool)
-> (NormalizedCut -> NormalizedCut -> Bool) -> Eq NormalizedCut
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NormalizedCut -> NormalizedCut -> Bool
== :: NormalizedCut -> NormalizedCut -> Bool
$c/= :: NormalizedCut -> NormalizedCut -> Bool
/= :: NormalizedCut -> NormalizedCut -> Bool
Eq, Eq NormalizedCut
Eq NormalizedCut
-> (NormalizedCut -> NormalizedCut -> Ordering)
-> (NormalizedCut -> NormalizedCut -> Bool)
-> (NormalizedCut -> NormalizedCut -> Bool)
-> (NormalizedCut -> NormalizedCut -> Bool)
-> (NormalizedCut -> NormalizedCut -> Bool)
-> (NormalizedCut -> NormalizedCut -> NormalizedCut)
-> (NormalizedCut -> NormalizedCut -> NormalizedCut)
-> Ord NormalizedCut
NormalizedCut -> NormalizedCut -> Bool
NormalizedCut -> NormalizedCut -> Ordering
NormalizedCut -> NormalizedCut -> NormalizedCut
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NormalizedCut -> NormalizedCut -> Ordering
compare :: NormalizedCut -> NormalizedCut -> Ordering
$c< :: NormalizedCut -> NormalizedCut -> Bool
< :: NormalizedCut -> NormalizedCut -> Bool
$c<= :: NormalizedCut -> NormalizedCut -> Bool
<= :: NormalizedCut -> NormalizedCut -> Bool
$c> :: NormalizedCut -> NormalizedCut -> Bool
> :: NormalizedCut -> NormalizedCut -> Bool
$c>= :: NormalizedCut -> NormalizedCut -> Bool
>= :: NormalizedCut -> NormalizedCut -> Bool
$cmax :: NormalizedCut -> NormalizedCut -> NormalizedCut
max :: NormalizedCut -> NormalizedCut -> NormalizedCut
$cmin :: NormalizedCut -> NormalizedCut -> NormalizedCut
min :: NormalizedCut -> NormalizedCut -> NormalizedCut
Ord, Int -> NormalizedCut -> ShowS
[NormalizedCut] -> ShowS
NormalizedCut -> String
(Int -> NormalizedCut -> ShowS)
-> (NormalizedCut -> String)
-> ([NormalizedCut] -> ShowS)
-> Show NormalizedCut
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NormalizedCut -> ShowS
showsPrec :: Int -> NormalizedCut -> ShowS
$cshow :: NormalizedCut -> String
show :: NormalizedCut -> String
$cshowList :: [NormalizedCut] -> ShowS
showList :: [NormalizedCut] -> ShowS
Show)

-- | Cut a finite piece of paper in one or two parts with an infinite scissors line
-- (depending on whether the scissors miss the line or not).
cutLineWithLine :: Line -> Line -> CutLine
cutLineWithLine :: Line -> Line -> CutLine
cutLineWithLine Line
scissors Line
paper = case Line -> Line -> LLIntersection
intersectionLL Line
scissors Line
paper of
    IntersectionReal Vec2
p           -> Vec2 -> CutLine
cut Vec2
p
    IntersectionVirtualInsideR Vec2
p -> Vec2 -> CutLine
cut Vec2
p
    Collinear Maybe Line
_                  -> Vec2 -> CutLine
cut Vec2
paperStart -- any point is good enough
    LLIntersection
_otherwise                   -> CutLine
noCut
  where
    Line Vec2
paperStart Vec2
paperEnd = Line
paper
    cut :: Vec2 -> CutLine
cut Vec2
p = Vec2 -> Vec2 -> Vec2 -> CutLine
Cut Vec2
paperStart Vec2
p Vec2
paperEnd
    noCut :: CutLine
noCut = Vec2 -> Vec2 -> CutLine
NoCut Vec2
paperStart Vec2
paperEnd

-- | Cut a polygon in multiple pieces with a line.
--
-- For convex polygons, the result is either just the polygon (if the line
-- misses) or two pieces. Concave polygons can in general be divided in
-- arbitrarily many pieces.
--
-- <<docs/geometry/clipping/3_complicated.svg>>
cutPolygon :: Line -> Polygon -> [Polygon]
cutPolygon :: Line -> Polygon -> [Polygon]
cutPolygon Line
scissors Polygon
polygon =
    -- The idea here is as follows:
    --
    -- A polygon can be seen as a cyclic graph where each corner points to the
    --next. We can reconstruct the polygon by looking for a cycle.
    --
    -- We can use this idea to cut the polygon: a cut introduces new edges into
    -- our corner graph, going from the start of the cut to the end. We can then
    -- get all the pieces of the cut by looking for all the cycles in that graph.
    PolygonOrientation -> EdgeGraph -> [Polygon]
reconstructPolygons
        (Polygon -> PolygonOrientation
polygonOrientation Polygon
polygon)
        (Line -> PolygonOrientation -> [CutLine] -> EdgeGraph
createEdgeGraph Line
scissors (Polygon -> PolygonOrientation
polygonOrientation Polygon
polygon)
            ((Line -> CutLine) -> [Line] -> [CutLine]
forall a b. (a -> b) -> [a] -> [b]
map (Line -> Line -> CutLine
cutLineWithLine Line
scissors)
                 (Polygon -> [Line]
polygonEdges Polygon
polygon)))

createEdgeGraph :: Line -> PolygonOrientation -> [CutLine] -> EdgeGraph
createEdgeGraph :: Line -> PolygonOrientation -> [CutLine] -> EdgeGraph
createEdgeGraph Line
scissors PolygonOrientation
orientation [CutLine]
allCuts = [Edge] -> EdgeGraph
forall (f :: * -> *). Foldable f => f Edge -> EdgeGraph
buildGraph ([Edge]
addCutEdges [Edge] -> [Edge] -> [Edge]
forall a. [a] -> [a] -> [a]
++ [Edge]
addOriginalPolygon)
  where
    addCutEdges :: [Edge]
addCutEdges = Line -> PolygonOrientation -> [CutLine] -> [Edge]
cutsToEdges Line
scissors PolygonOrientation
orientation [CutLine]
allCuts
    addOriginalPolygon :: [Edge]
addOriginalPolygon = [CutLine] -> [Edge]
polygonToEdges [CutLine]
allCuts

buildGraph :: Foldable f => f Edge -> EdgeGraph
buildGraph :: forall (f :: * -> *). Foldable f => f Edge -> EdgeGraph
buildGraph = (EdgeGraph -> Edge -> EdgeGraph)
-> EdgeGraph -> f Edge -> EdgeGraph
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\graph :: EdgeGraph
graph@(EdgeGraph Map Vec2 (Set Vec2)
g) (Edge Vec2
start Vec2
end) -> if Vec2
start Vec2 -> Vec2 -> Bool
forall a. Eq a => a -> a -> Bool
== Vec2
end then EdgeGraph
graph else Map Vec2 (Set Vec2) -> EdgeGraph
EdgeGraph ((Set Vec2 -> Set Vec2 -> Set Vec2)
-> Vec2 -> Set Vec2 -> Map Vec2 (Set Vec2) -> Map Vec2 (Set Vec2)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Set Vec2 -> Set Vec2 -> Set Vec2
forall a. Ord a => Set a -> Set a -> Set a
S.union Vec2
start (Vec2 -> Set Vec2
forall a. a -> Set a
S.singleton Vec2
end) Map Vec2 (Set Vec2)
g)) EdgeGraph
forall a. Monoid a => a
mempty

cutsToEdges :: Line -> PolygonOrientation -> [CutLine] -> [Edge]
cutsToEdges :: Line -> PolygonOrientation -> [CutLine] -> [Edge]
cutsToEdges Line
scissors PolygonOrientation
orientation [CutLine]
cuts = [NormalizedCut] -> [Edge]
go (Line -> PolygonOrientation -> [CutLine] -> [NormalizedCut]
cutPointsSorted Line
scissors PolygonOrientation
orientation [CutLine]
cuts)
  where
    go :: [NormalizedCut] -> [Edge]
    go :: [NormalizedCut] -> [Edge]
go [] = []

    -- Default path: Scissors enter and exit again
    go (Entering Vec2
p : Exiting Vec2
q : [NormalizedCut]
rest)
      = (Vec2
p Vec2 -> Vec2 -> Edge
--> Vec2
q) Edge -> [Edge] -> [Edge]
forall a. a -> [a] -> [a]
: (Vec2
q Vec2 -> Vec2 -> Edge
--> Vec2
p) Edge -> [Edge] -> [Edge]
forall a. a -> [a] -> [a]
: [NormalizedCut] -> [Edge]
go [NormalizedCut]
rest

    -- Touching the polygon along a line, and exiting it afterwards:
    -- Looks like we did enter along the line.
    go (AlongEdge Vec2
_ Vec2
p : Exiting Vec2
q : [NormalizedCut]
rest)
      = [NormalizedCut] -> [Edge]
go (Vec2 -> NormalizedCut
Entering Vec2
p NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: Vec2 -> NormalizedCut
Exiting Vec2
q NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: [NormalizedCut]
rest)

    -- Touching the polygon, but not entering it: Just ignore
    go (Touching Vec2
_ : [NormalizedCut]
rest)
      = [NormalizedCut] -> [Edge]
go [NormalizedCut]
rest

    -- Touching the polygon along two successive lines: Merge them
    -- (This should already be merged, but doesn't harm here)
    go (AlongEdge Vec2
p Vec2
_ : AlongEdge Vec2
_ Vec2
q : [NormalizedCut]
rest)
      = [NormalizedCut] -> [Edge]
go (Vec2 -> Vec2 -> NormalizedCut
AlongEdge Vec2
p Vec2
q NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: [NormalizedCut]
rest)

    -- Going along an edge without entering or exiting: Ignore the edge
    go (AlongEdge Vec2
_ Vec2
_ : [NormalizedCut]
rest)
      = [NormalizedCut] -> [Edge]
go [NormalizedCut]
rest

    -- Touching a point while inside the polygon:
    -- Treat it like entering, exiting, and re-entering
    go (Entering Vec2
p : Touching Vec2
q : [NormalizedCut]
rest)
      = [NormalizedCut] -> [Edge]
go (Vec2 -> NormalizedCut
Entering Vec2
p NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: Vec2 -> NormalizedCut
Exiting Vec2
q NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: Vec2 -> NormalizedCut
Entering Vec2
q NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: [NormalizedCut]
rest)

    -- Same here, but we cannot re-enter, need to first follow along the cut
    go (Entering Vec2
p : AlongEdge Vec2
q Vec2
r : [NormalizedCut]
rest)
      = [NormalizedCut] -> [Edge]
go (Vec2 -> NormalizedCut
Entering Vec2
p NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: Vec2 -> NormalizedCut
Exiting Vec2
q NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: Vec2 -> Vec2 -> NormalizedCut
AlongEdge Vec2
q Vec2
r NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: [NormalizedCut]
rest)

    -- I encountered this bug a few times now: Two cuts in the wrong order.
    -- I haven't debugged this to find out where it goes wrong, but it looks
    -- like this is a pretty safe workaround.
    go [Exiting Vec2
p, Entering Vec2
q]
      = [NormalizedCut] -> [Edge]
go [Vec2 -> NormalizedCut
Entering Vec2
p, Vec2 -> NormalizedCut
Exiting Vec2
q]

    go [NormalizedCut]
bad
      = String -> String -> [Edge]
forall a. String -> String -> a
bugError String
"Cut.Internal.newCutsGraphEdges" (String -> [Edge]) -> String -> [Edge]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
          [ String
"Expecting patterns to be exhaustive, but apparently it's not."
          , String
"Bad portion: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [NormalizedCut] -> String
forall a. Show a => a -> String
show [NormalizedCut]
bad
          , String
"Full list of cut lines: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [NormalizedCut] -> String
forall a. Show a => a -> String
show (Line -> PolygonOrientation -> [CutLine] -> [NormalizedCut]
cutPointsSorted Line
scissors PolygonOrientation
orientation [CutLine]
cuts) ]

-- | Sort cut points by location on the scissors
cutPointsSorted :: Line -> PolygonOrientation -> [CutLine] -> [NormalizedCut]
cutPointsSorted :: Line -> PolygonOrientation -> [CutLine] -> [NormalizedCut]
cutPointsSorted Line
scissors PolygonOrientation
orientation [CutLine]
cuts = (NormalizedCut -> Double) -> [NormalizedCut] -> [NormalizedCut]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Line -> NormalizedCut -> Double
scissorCoordinate Line
scissors) (Line -> PolygonOrientation -> [CutLine] -> [NormalizedCut]
normalizeCuts Line
scissors PolygonOrientation
orientation [CutLine]
cuts)

-- How far ahead/behind the start of the line is the point?
--
-- In mathematical terms, this yields the coordinate of a point in the
-- 1-dimensional vector space that is the scissors line.
scissorCoordinate :: Line -> NormalizedCut -> Double
scissorCoordinate :: Line -> NormalizedCut -> Double
scissorCoordinate scissors :: Line
scissors@(Line Vec2
scissorsStart Vec2
_) NormalizedCut
nc = case NormalizedCut
nc of
    Entering Vec2
x -> Vec2 -> Double
positionAlongScissor Vec2
x
    Exiting Vec2
x -> Vec2 -> Double
positionAlongScissor Vec2
x
    Touching Vec2
x -> Vec2 -> Double
positionAlongScissor Vec2
x
    AlongEdge Vec2
x Vec2
y -> Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Vec2 -> Double
positionAlongScissor Vec2
x) (Vec2 -> Double
positionAlongScissor Vec2
y)
    where
    positionAlongScissor :: Vec2 -> Double
positionAlongScissor Vec2
p = Vec2 -> Vec2 -> Double
dotProduct (Line -> Vec2
vectorOf Line
scissors) (Line -> Vec2
vectorOf (Vec2 -> Vec2 -> Line
Line Vec2
scissorsStart Vec2
p))

-- A polygon can be described by an adjacency list of corners to the next
-- corner. A cut simply introduces two new corners (of polygons to be) that
-- point to each other.
polygonToEdges :: [CutLine] -> [Edge]
polygonToEdges :: [CutLine] -> [Edge]
polygonToEdges [CutLine]
cuts = case [CutLine]
cuts of
    Cut Vec2
p Vec2
x Vec2
q : [CutLine]
rest -> (Vec2
p Vec2 -> Vec2 -> Edge
--> Vec2
x) Edge -> [Edge] -> [Edge]
forall a. a -> [a] -> [a]
: (Vec2
x Vec2 -> Vec2 -> Edge
--> Vec2
q) Edge -> [Edge] -> [Edge]
forall a. a -> [a] -> [a]
: [CutLine] -> [Edge]
polygonToEdges [CutLine]
rest
    NoCut Vec2
p Vec2
q : [CutLine]
rest -> (Vec2
p Vec2 -> Vec2 -> Edge
--> Vec2
q) Edge -> [Edge] -> [Edge]
forall a. a -> [a] -> [a]
: [CutLine] -> [Edge]
polygonToEdges [CutLine]
rest
    []               -> []

-- | Given a list of corners that point to other corners, we can reconstruct all
-- the polygons described by them by finding the smallest cycles, i.e. cycles that
-- do not contain other (parts of the) adjacency map.
--
-- Starting at an arbitrary point, we can extract a single polygon by
-- following such a minimal cycle; iterating this algorithm until the entire
-- map has been consumed yields all the polygons.
reconstructPolygons :: PolygonOrientation -> EdgeGraph -> [Polygon]
reconstructPolygons :: PolygonOrientation -> EdgeGraph -> [Polygon]
reconstructPolygons PolygonOrientation
orientation edgeGraph :: EdgeGraph
edgeGraph@(EdgeGraph Map Vec2 (Set Vec2)
graphMap) = case Map Vec2 (Set Vec2) -> Maybe (Vec2, Set Vec2)
forall k a. Map k a -> Maybe (k, a)
M.lookupMin Map Vec2 (Set Vec2)
graphMap of
    Maybe (Vec2, Set Vec2)
Nothing -> []
    Just (Vec2
edgeStart, Set Vec2
_end) -> case Polygon
poly of
        Polygon (Vec2
_:[Vec2]
_) -> Polygon
poly Polygon -> [Polygon] -> [Polygon]
forall a. a -> [a] -> [a]
: PolygonOrientation -> EdgeGraph -> [Polygon]
reconstructPolygons PolygonOrientation
orientation EdgeGraph
edgeGraph'
        Polygon
_otherwise -> String -> String -> [Polygon]
forall a. String -> String -> a
bugError String
"Cut.Internal.reconstructPolygons" (String -> [Polygon]) -> String -> [Polygon]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
            [ String
"Empty Polygon constructed from edge graph."
            , String
"This means that the edge graph cannot be deconstructed further:"
            , EdgeGraph -> String
forall a. Show a => a -> String
show EdgeGraph
edgeGraph ]
      where (Polygon
poly, EdgeGraph
edgeGraph') = PolygonOrientation -> Vec2 -> EdgeGraph -> (Polygon, EdgeGraph)
extractSinglePolygon PolygonOrientation
orientation Vec2
edgeStart EdgeGraph
edgeGraph

-- | Extract a single polygon from an edge map by finding a minimal circular
-- connection.
extractSinglePolygon
    :: PolygonOrientation
    -> Vec2                    -- ^ Starting point
    -> EdgeGraph            -- ^ Edge map
    -> (Polygon, EdgeGraph) -- ^ Extracted polygon and remaining edge map
extractSinglePolygon :: PolygonOrientation -> Vec2 -> EdgeGraph -> (Polygon, EdgeGraph)
extractSinglePolygon PolygonOrientation
orientation = Maybe Vec2 -> Set Vec2 -> Vec2 -> EdgeGraph -> (Polygon, EdgeGraph)
go Maybe Vec2
forall a. Maybe a
Nothing Set Vec2
forall a. Set a
S.empty
  where
    go :: Maybe Vec2 -> Set Vec2 -> Vec2 -> EdgeGraph -> (Polygon, EdgeGraph)
go Maybe Vec2
lastPivot Set Vec2
visited Vec2
pivot edgeGraph :: EdgeGraph
edgeGraph@(EdgeGraph Map Vec2 (Set Vec2)
edgeMap) = case Vec2 -> Map Vec2 (Set Vec2) -> Maybe (Set Vec2)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Vec2
pivot Map Vec2 (Set Vec2)
edgeMap of

        -- We were already here: terminate (TODO: shouldn’t this be an error?)
        Maybe (Set Vec2)
_ | Vec2 -> Set Vec2 -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Vec2
pivot Set Vec2
visited -> ([Vec2] -> Polygon
Polygon [], EdgeGraph
edgeGraph)

        -- The pivot is not in the edge map: terminate. (TODO: shouldn’t this be an error?)
        Maybe (Set Vec2)
Nothing -> ([Vec2] -> Polygon
Polygon [], EdgeGraph
edgeGraph)

        Just Set Vec2
toVertices -> case Set Vec2 -> Maybe (Vec2, Set Vec2)
forall a. Set a -> Maybe (a, Set a)
S.minView Set Vec2
toVertices of
            -- The pivot is there, but does not point anywhere. (TODO: shouldn’t this be an error?)
            Maybe (Vec2, Set Vec2)
Nothing -> ([Vec2] -> Polygon
Polygon [], EdgeGraph
edgeGraph)

            -- The pivot points to a single target; follow the pointer
            Just (Vec2
next, Set Vec2
nothingLeft) | Set Vec2 -> Bool
forall a. Set a -> Bool
S.null Set Vec2
nothingLeft ->
                let (Polygon [Vec2]
rest, EdgeGraph
edgeGraph') = Maybe Vec2 -> Set Vec2 -> Vec2 -> EdgeGraph -> (Polygon, EdgeGraph)
go
                        (Vec2 -> Maybe Vec2
forall a. a -> Maybe a
Just Vec2
pivot)
                        (Vec2 -> Set Vec2 -> Set Vec2
forall a. Ord a => a -> Set a -> Set a
S.insert Vec2
pivot Set Vec2
visited)
                        Vec2
next
                        (Map Vec2 (Set Vec2) -> EdgeGraph
EdgeGraph (Vec2 -> Map Vec2 (Set Vec2) -> Map Vec2 (Set Vec2)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Vec2
pivot Map Vec2 (Set Vec2)
edgeMap))
                in ([Vec2] -> Polygon
Polygon (Vec2
pivotVec2 -> [Vec2] -> [Vec2]
forall a. a -> [a] -> [a]
:[Vec2]
rest), EdgeGraph
edgeGraph')

            -- The pivot points to multiple targets; follow the direction of the smallest loop
            Just (Vec2
next1, Set Vec2
_) ->
                let useAsNext :: Vec2
useAsNext = case Maybe Vec2
lastPivot of
                        Maybe Vec2
Nothing -> Vec2
next1 -- There was no previous pivot; pick an arbitrary starting point WLOG
                        Just Vec2
from ->
                            let leftness, rightness :: Vec2 -> Angle
                                leftness :: Vec2 -> Angle
leftness Vec2
end = Angle -> Angle -> Angle
normalizeAngle (Double -> Angle
rad Double
0) (Line -> Angle
angleOfLine (Vec2 -> Vec2 -> Line
Line Vec2
pivot Vec2
from) Angle -> Angle -> Angle
forall v. VectorSpace v => v -> v -> v
-. Line -> Angle
angleOfLine (Vec2 -> Vec2 -> Line
Line Vec2
pivot Vec2
end))
                                rightness :: Vec2 -> Angle
rightness Vec2
end = Angle -> Angle
forall v. VectorSpace v => v -> v
negateV (Vec2 -> Angle
leftness Vec2
end)
                                pickNextVertex :: Set Vec2 -> Vec2
pickNextVertex = (Vec2 -> Vec2 -> Ordering) -> Set Vec2 -> Vec2
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((Vec2 -> Vec2 -> Ordering) -> Set Vec2 -> Vec2)
-> (Vec2 -> Vec2 -> Ordering) -> Set Vec2 -> Vec2
forall a b. (a -> b) -> a -> b
$ (Vec2 -> Double) -> Vec2 -> Vec2 -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Vec2 -> Double) -> Vec2 -> Vec2 -> Ordering)
-> (Vec2 -> Double) -> Vec2 -> Vec2 -> Ordering
forall a b. (a -> b) -> a -> b
$ case PolygonOrientation
orientation of
                                    -- TODO: comparing by angles is flaky because of their modular arithmetic.
                                    -- leftness/rightness should be rewritten in terms of 'cross', which allows
                                    -- judging whether a vector is left/right of another much better.
                                    -- The 'getRad' was just put here quickly so the 'Ord Angle' instance
                                    -- could be removed.
                                    PolygonOrientation
PolygonPositive -> Angle -> Double
getRad (Angle -> Double) -> (Vec2 -> Angle) -> Vec2 -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vec2 -> Angle
leftness
                                    PolygonOrientation
PolygonNegative -> Angle -> Double
getRad (Angle -> Double) -> (Vec2 -> Angle) -> Vec2 -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vec2 -> Angle
rightness
                            in Set Vec2 -> Vec2
pickNextVertex (Vec2 -> Set Vec2 -> Set Vec2
forall a. Ord a => a -> Set a -> Set a
S.delete Vec2
from Set Vec2
toVertices)
                    otherVertices :: Set Vec2
otherVertices = Vec2 -> Set Vec2 -> Set Vec2
forall a. Ord a => a -> Set a -> Set a
S.delete Vec2
useAsNext Set Vec2
toVertices
                    (Polygon [Vec2]
rest, EdgeGraph
edgeGraph') = Maybe Vec2 -> Set Vec2 -> Vec2 -> EdgeGraph -> (Polygon, EdgeGraph)
go
                        (Vec2 -> Maybe Vec2
forall a. a -> Maybe a
Just Vec2
pivot)
                        (Vec2 -> Set Vec2 -> Set Vec2
forall a. Ord a => a -> Set a -> Set a
S.insert Vec2
pivot Set Vec2
visited)
                        Vec2
useAsNext
                        (Map Vec2 (Set Vec2) -> EdgeGraph
EdgeGraph (Vec2 -> Set Vec2 -> Map Vec2 (Set Vec2) -> Map Vec2 (Set Vec2)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Vec2
pivot Set Vec2
otherVertices Map Vec2 (Set Vec2)
edgeMap))
                in ([Vec2] -> Polygon
Polygon (Vec2
pivotVec2 -> [Vec2] -> [Vec2]
forall a. a -> [a] -> [a]
:[Vec2]
rest), EdgeGraph
edgeGraph')

normalizeCuts :: Line -> PolygonOrientation -> [CutLine] -> [NormalizedCut]
normalizeCuts :: Line -> PolygonOrientation -> [CutLine] -> [NormalizedCut]
normalizeCuts Line
_ PolygonOrientation
_ [] = []
normalizeCuts Line
scissors PolygonOrientation
orientation [CutLine]
cutLines =
    [(Vec2, CutType)] -> [NormalizedCut]
go ([(Vec2, CutType)] -> [(Vec2, CutType)]
forall {a}. [(a, CutType)] -> [(a, CutType)]
rotateToEntryPoint ((CutLine -> Maybe (Vec2, CutType))
-> [CutLine] -> [(Vec2, CutType)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Line -> CutLine -> Maybe (Vec2, CutType)
classifyCut Line
scissors) [CutLine]
cutLines))
  where
    go :: [(Vec2, CutType)] -> [NormalizedCut]
    go :: [(Vec2, CutType)] -> [NormalizedCut]
go [] = []
    go ((Vec2
x, CutType
ty) : [(Vec2, CutType)]
cuts)
        -- regular cuts, just collect them
        | CutType
ty CutType -> [CutType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CutType
LR, CutType
RL] = CutType -> Vec2 -> NormalizedCut
normalizedCutFor CutType
ty Vec2
x NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: [(Vec2, CutType)] -> [NormalizedCut]
go [(Vec2, CutType)]
cuts

        -- cuts through vertex need to be merged with the next cut
        -- they come in pairs, or even more (for cuts along a line)
        | CutType
ty CutType -> [CutType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CutType
LO, CutType
RO] = (Vec2, CutType) -> [(Vec2, CutType)] -> [NormalizedCut]
mergeCutsThroughVertex (Vec2
x, CutType
ty) [(Vec2, CutType)]
cuts

        -- Everything else is an error (OX: this should be prevented by rotateToEntryPoint/mergeCutsThroughVertex)
        | Bool
otherwise = String -> String -> [NormalizedCut]
forall a. String -> String -> a
bugError String
"Cut.Internal.normalizeCuts.go" (String -> [NormalizedCut]) -> String -> [NormalizedCut]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
            [ String
"Found invalid cut type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CutType -> String
forall a. Show a => a -> String
show CutType
ty
            , String
"Maybe rotateToEntryPoint did not work as expected?" ]

    mergeCutsThroughVertex :: (Vec2, CutType) -> [(Vec2, CutType)] -> [NormalizedCut]
    mergeCutsThroughVertex :: (Vec2, CutType) -> [(Vec2, CutType)] -> [NormalizedCut]
mergeCutsThroughVertex (Vec2
x, CutType
ty) [(Vec2, CutType)]
cuts = case (CutType
ty, [(Vec2, CutType)]
cuts) of
        -- A cut through a vertex results in two entries, merge them into one cut.
        -- We can ignore the second cut point, it should be identical to x
        (CutType
LO, (Vec2
_, CutType
OR) : [(Vec2, CutType)]
rest) -> CutType -> Vec2 -> NormalizedCut
normalizedCutFor CutType
LR Vec2
x NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: [(Vec2, CutType)] -> [NormalizedCut]
go [(Vec2, CutType)]
rest
        (CutType
RO, (Vec2
_, CutType
OL) : [(Vec2, CutType)]
rest) -> CutType -> Vec2 -> NormalizedCut
normalizedCutFor CutType
RL Vec2
x NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: [(Vec2, CutType)] -> [NormalizedCut]
go [(Vec2, CutType)]
rest
        (CutType
LO, (Vec2
_, CutType
OL) : [(Vec2, CutType)]
rest) -> Vec2 -> NormalizedCut
Touching Vec2
x NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: [(Vec2, CutType)] -> [NormalizedCut]
go [(Vec2, CutType)]
rest
        (CutType
RO, (Vec2
_, CutType
OR) : [(Vec2, CutType)]
rest) -> Vec2 -> NormalizedCut
Touching Vec2
x NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: [(Vec2, CutType)] -> [NormalizedCut]
go [(Vec2, CutType)]
rest
        -- A cut along a line is more complicated: We ignore the cut in between
        -- that is completely along the line, and follow the line
        -- until we reach an edge that leads away from the cut.
        (CutType
_, (Vec2
_, CutType
OO) : [(Vec2, CutType)]
rest) -> Vec2 -> [(Vec2, CutType)] -> [NormalizedCut]
followCutAlongLine Vec2
x [(Vec2, CutType)]
rest
        (CutType, [(Vec2, CutType)])
other -> String -> String -> [NormalizedCut]
forall a. String -> String -> a
bugError String
"Cut.Internal.normalizeCuts.mergeCutsThroughVertex" (String
"Encountered unexpected cut type when merging cuts through vertex: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (CutType, [(Vec2, CutType)]) -> String
forall a. Show a => a -> String
show (CutType, [(Vec2, CutType)])
other)

    followCutAlongLine :: Vec2 -> [(Vec2, CutType)] -> [NormalizedCut]
    followCutAlongLine :: Vec2 -> [(Vec2, CutType)] -> [NormalizedCut]
followCutAlongLine Vec2
x ((Vec2
y, CutType
yTy) : [(Vec2, CutType)]
rest) = case CutType
yTy of
        -- Another cut along the line, skip again
        CutType
OO -> Vec2 -> [(Vec2, CutType)] -> [NormalizedCut]
followCutAlongLine Vec2
x [(Vec2, CutType)]
rest
        -- Found the edge that leads away from the cut line
        CutType
OL -> Vec2 -> Vec2 -> NormalizedCut
AlongEdge Vec2
x Vec2
y NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: [(Vec2, CutType)] -> [NormalizedCut]
go [(Vec2, CutType)]
rest
        CutType
OR -> Vec2 -> Vec2 -> NormalizedCut
AlongEdge Vec2
x Vec2
y NormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
: [(Vec2, CutType)] -> [NormalizedCut]
go [(Vec2, CutType)]
rest
        -- Either the function was called with the wrong input, or the polygon was inconsistent
        CutType
_ -> String -> String -> [NormalizedCut]
forall a. String -> String -> a
bugError String
"Cut.Internal.normalizeCuts.followCutAlongLine" String
"Tried to follow cut along line, but there is no valid option to follow."
    followCutAlongLine Vec2
_ [] = String -> String -> [NormalizedCut]
forall a. String -> String -> a
bugError String
"Cut.Internal.normalizeCuts.followCutAlongLine" String
"Tried to follow cut along line, but there is nothing to follow"

    normalizedCutFor :: CutType -> Vec2 -> NormalizedCut
    normalizedCutFor :: CutType -> Vec2 -> NormalizedCut
normalizedCutFor CutType
LR = case PolygonOrientation
orientation of
        PolygonOrientation
PolygonPositive -> Vec2 -> NormalizedCut
Entering
        PolygonOrientation
PolygonNegative -> Vec2 -> NormalizedCut
Exiting
    normalizedCutFor CutType
RL = case PolygonOrientation
orientation of
        PolygonOrientation
PolygonNegative -> Vec2 -> NormalizedCut
Entering
        PolygonOrientation
PolygonPositive -> Vec2 -> NormalizedCut
Exiting
    normalizedCutFor CutType
other = String -> String -> Vec2 -> NormalizedCut
forall a. String -> String -> a
bugError String
"Cut.Internal.normalizeCuts.normalizedCutFor" (String -> Vec2 -> NormalizedCut)
-> String -> Vec2 -> NormalizedCut
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
        [ String
"Can only normalize cuts that cross the line, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CutType -> String
forall a. Show a => a -> String
show CutType
other
        , String
"Maybe mergeCutsThroughVertex should be applied?" ]

    rotateToEntryPoint :: [(a, CutType)] -> [(a, CutType)]
rotateToEntryPoint [] = []
    rotateToEntryPoint (c :: (a, CutType)
c@(a
_, CutType
ty) : [(a, CutType)]
cs)
        | CutType
ty CutType -> [CutType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CutType
LR, CutType
RL, CutType
LO, CutType
RO] = (a, CutType)
c(a, CutType) -> [(a, CutType)] -> [(a, CutType)]
forall a. a -> [a] -> [a]
:[(a, CutType)]
cs
        | Bool
otherwise = [(a, CutType)] -> [(a, CutType)]
rotateToEntryPoint ([(a, CutType)]
cs [(a, CutType)] -> [(a, CutType)] -> [(a, CutType)]
forall a. [a] -> [a] -> [a]
++ [(a, CutType)
c])

classifyCut :: Line -> CutLine -> Maybe (Vec2, CutType)
classifyCut :: Line -> CutLine -> Maybe (Vec2, CutType)
classifyCut Line
_ NoCut{} = Maybe (Vec2, CutType)
forall a. Maybe a
Nothing
classifyCut Line
scissors (Cut Vec2
l Vec2
x Vec2
r)
  = (Vec2, CutType) -> Maybe (Vec2, CutType)
forall a. a -> Maybe a
Just ((Vec2, CutType) -> Maybe (Vec2, CutType))
-> (Vec2, CutType) -> Maybe (Vec2, CutType)
forall a b. (a -> b) -> a -> b
$ case (Line -> Vec2 -> SideOfLine
sideOfScissors Line
scissors Vec2
l, Line -> Vec2 -> SideOfLine
sideOfScissors Line
scissors Vec2
r) of
        (SideOfLine
LeftOfLine,     SideOfLine
RightOfLine)    -> (Vec2
x, CutType
LR)
        (SideOfLine
RightOfLine,    SideOfLine
LeftOfLine)     -> (Vec2
x, CutType
RL)
        (SideOfLine
DirectlyOnLine, SideOfLine
DirectlyOnLine) -> (Vec2
x, CutType
OO)
        (SideOfLine
DirectlyOnLine, SideOfLine
LeftOfLine)     -> (Vec2
x, CutType
OL)
        (SideOfLine
DirectlyOnLine, SideOfLine
RightOfLine)    -> (Vec2
x, CutType
OR)
        (SideOfLine
LeftOfLine,     SideOfLine
DirectlyOnLine) -> (Vec2
x, CutType
LO)
        (SideOfLine
RightOfLine,    SideOfLine
DirectlyOnLine) -> (Vec2
x, CutType
RO)
        (SideOfLine, SideOfLine)
other -> String -> String -> (Vec2, CutType)
forall a. String -> String -> a
bugError String
"Cut.Internal.classifyCut" (String
"Unexpected cut that cannot be classified: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (SideOfLine, SideOfLine) -> String
forall a. Show a => a -> String
show (SideOfLine, SideOfLine)
other)

sideOfScissors :: Line -> Vec2 -> SideOfLine
sideOfScissors :: Line -> Vec2 -> SideOfLine
sideOfScissors scissors :: Line
scissors@(Line Vec2
scissorsStart Vec2
_) Vec2
p
  = let scissorsCrossPoint :: Double
scissorsCrossPoint = Vec2 -> Vec2 -> Double
cross (Line -> Vec2
vectorOf Line
scissors) (Line -> Vec2
vectorOf (Vec2 -> Vec2 -> Line
Line Vec2
scissorsStart Vec2
p))
    in case Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Double
scissorsCrossPoint Double
0 of
        Ordering
LT -> SideOfLine
RightOfLine
        Ordering
EQ -> SideOfLine
DirectlyOnLine
        Ordering
GT -> SideOfLine
LeftOfLine

data SideOfLine = LeftOfLine | DirectlyOnLine | RightOfLine
    deriving (SideOfLine -> SideOfLine -> Bool
(SideOfLine -> SideOfLine -> Bool)
-> (SideOfLine -> SideOfLine -> Bool) -> Eq SideOfLine
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SideOfLine -> SideOfLine -> Bool
== :: SideOfLine -> SideOfLine -> Bool
$c/= :: SideOfLine -> SideOfLine -> Bool
/= :: SideOfLine -> SideOfLine -> Bool
Eq, Eq SideOfLine
Eq SideOfLine
-> (SideOfLine -> SideOfLine -> Ordering)
-> (SideOfLine -> SideOfLine -> Bool)
-> (SideOfLine -> SideOfLine -> Bool)
-> (SideOfLine -> SideOfLine -> Bool)
-> (SideOfLine -> SideOfLine -> Bool)
-> (SideOfLine -> SideOfLine -> SideOfLine)
-> (SideOfLine -> SideOfLine -> SideOfLine)
-> Ord SideOfLine
SideOfLine -> SideOfLine -> Bool
SideOfLine -> SideOfLine -> Ordering
SideOfLine -> SideOfLine -> SideOfLine
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SideOfLine -> SideOfLine -> Ordering
compare :: SideOfLine -> SideOfLine -> Ordering
$c< :: SideOfLine -> SideOfLine -> Bool
< :: SideOfLine -> SideOfLine -> Bool
$c<= :: SideOfLine -> SideOfLine -> Bool
<= :: SideOfLine -> SideOfLine -> Bool
$c> :: SideOfLine -> SideOfLine -> Bool
> :: SideOfLine -> SideOfLine -> Bool
$c>= :: SideOfLine -> SideOfLine -> Bool
>= :: SideOfLine -> SideOfLine -> Bool
$cmax :: SideOfLine -> SideOfLine -> SideOfLine
max :: SideOfLine -> SideOfLine -> SideOfLine
$cmin :: SideOfLine -> SideOfLine -> SideOfLine
min :: SideOfLine -> SideOfLine -> SideOfLine
Ord, Int -> SideOfLine -> ShowS
[SideOfLine] -> ShowS
SideOfLine -> String
(Int -> SideOfLine -> ShowS)
-> (SideOfLine -> String)
-> ([SideOfLine] -> ShowS)
-> Show SideOfLine
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SideOfLine -> ShowS
showsPrec :: Int -> SideOfLine -> ShowS
$cshow :: SideOfLine -> String
show :: SideOfLine -> String
$cshowList :: [SideOfLine] -> ShowS
showList :: [SideOfLine] -> ShowS
Show)

-- | Nomenclature: Left/On/Right relative to scissors. LR means that the edge
-- leading to the cut comes from the left of the scissors, and the outgoing
-- edge extends to the right. LO means that the edge leading to the cut comes
-- from the left, but we cut exactly through the vertex.
data CutType = LO | LR | OL | OO | OR | RL | RO
    deriving (CutType -> CutType -> Bool
(CutType -> CutType -> Bool)
-> (CutType -> CutType -> Bool) -> Eq CutType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CutType -> CutType -> Bool
== :: CutType -> CutType -> Bool
$c/= :: CutType -> CutType -> Bool
/= :: CutType -> CutType -> Bool
Eq, Eq CutType
Eq CutType
-> (CutType -> CutType -> Ordering)
-> (CutType -> CutType -> Bool)
-> (CutType -> CutType -> Bool)
-> (CutType -> CutType -> Bool)
-> (CutType -> CutType -> Bool)
-> (CutType -> CutType -> CutType)
-> (CutType -> CutType -> CutType)
-> Ord CutType
CutType -> CutType -> Bool
CutType -> CutType -> Ordering
CutType -> CutType -> CutType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CutType -> CutType -> Ordering
compare :: CutType -> CutType -> Ordering
$c< :: CutType -> CutType -> Bool
< :: CutType -> CutType -> Bool
$c<= :: CutType -> CutType -> Bool
<= :: CutType -> CutType -> Bool
$c> :: CutType -> CutType -> Bool
> :: CutType -> CutType -> Bool
$c>= :: CutType -> CutType -> Bool
>= :: CutType -> CutType -> Bool
$cmax :: CutType -> CutType -> CutType
max :: CutType -> CutType -> CutType
$cmin :: CutType -> CutType -> CutType
min :: CutType -> CutType -> CutType
Ord, Int -> CutType -> ShowS
[CutType] -> ShowS
CutType -> String
(Int -> CutType -> ShowS)
-> (CutType -> String) -> ([CutType] -> ShowS) -> Show CutType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CutType -> ShowS
showsPrec :: Int -> CutType -> ShowS
$cshow :: CutType -> String
show :: CutType -> String
$cshowList :: [CutType] -> ShowS
showList :: [CutType] -> ShowS
Show)

data LineType = LineInsidePolygon | LineOutsidePolygon
    deriving (LineType -> LineType -> Bool
(LineType -> LineType -> Bool)
-> (LineType -> LineType -> Bool) -> Eq LineType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LineType -> LineType -> Bool
== :: LineType -> LineType -> Bool
$c/= :: LineType -> LineType -> Bool
/= :: LineType -> LineType -> Bool
Eq, Eq LineType
Eq LineType
-> (LineType -> LineType -> Ordering)
-> (LineType -> LineType -> Bool)
-> (LineType -> LineType -> Bool)
-> (LineType -> LineType -> Bool)
-> (LineType -> LineType -> Bool)
-> (LineType -> LineType -> LineType)
-> (LineType -> LineType -> LineType)
-> Ord LineType
LineType -> LineType -> Bool
LineType -> LineType -> Ordering
LineType -> LineType -> LineType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LineType -> LineType -> Ordering
compare :: LineType -> LineType -> Ordering
$c< :: LineType -> LineType -> Bool
< :: LineType -> LineType -> Bool
$c<= :: LineType -> LineType -> Bool
<= :: LineType -> LineType -> Bool
$c> :: LineType -> LineType -> Bool
> :: LineType -> LineType -> Bool
$c>= :: LineType -> LineType -> Bool
>= :: LineType -> LineType -> Bool
$cmax :: LineType -> LineType -> LineType
max :: LineType -> LineType -> LineType
$cmin :: LineType -> LineType -> LineType
min :: LineType -> LineType -> LineType
Ord, Int -> LineType -> ShowS
[LineType] -> ShowS
LineType -> String
(Int -> LineType -> ShowS)
-> (LineType -> String) -> ([LineType] -> ShowS) -> Show LineType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LineType -> ShowS
showsPrec :: Int -> LineType -> ShowS
$cshow :: LineType -> String
show :: LineType -> String
$cshowList :: [LineType] -> ShowS
showList :: [LineType] -> ShowS
Show)

-- | Classify lines on the scissors as being inside or outside the polygon.
clipPolygonWithLine :: Polygon -> Line -> [(Line, LineType)]
clipPolygonWithLine :: Polygon -> Line -> [(Line, LineType)]
clipPolygonWithLine Polygon
polygon Line
scissors = [NormalizedCut] -> [(Line, LineType)]
reconstruct [NormalizedCut]
normalizedCuts

  where
    allCuts :: [CutLine]
allCuts = (Line -> CutLine) -> [Line] -> [CutLine]
forall a b. (a -> b) -> [a] -> [b]
map (Line -> Line -> CutLine
cutLineWithLine Line
scissors) (Polygon -> [Line]
polygonEdges Polygon
polygon)
    orientation :: PolygonOrientation
orientation = Polygon -> PolygonOrientation
polygonOrientation Polygon
polygon
    normalizedCuts :: [NormalizedCut]
normalizedCuts = Line -> PolygonOrientation -> [CutLine] -> [NormalizedCut]
cutPointsSorted Line
scissors PolygonOrientation
orientation [CutLine]
allCuts

    -- Happy path
    reconstruct :: [NormalizedCut] -> [(Line, LineType)]
reconstruct (Entering Vec2
start : rest :: [NormalizedCut]
rest@((Exiting Vec2
end) : [NormalizedCut]
_)) = (Vec2 -> Vec2 -> Line
Line Vec2
start Vec2
end, LineType
LineInsidePolygon) (Line, LineType) -> [(Line, LineType)] -> [(Line, LineType)]
forall a. a -> [a] -> [a]
: [NormalizedCut] -> [(Line, LineType)]
reconstruct [NormalizedCut]
rest
    reconstruct (e :: NormalizedCut
e@Entering{} : AlongEdge{} : [NormalizedCut]
rest) = [NormalizedCut] -> [(Line, LineType)]
reconstruct (NormalizedCut
eNormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
:[NormalizedCut]
rest) -- We ignore the alongEdge part here, much like the 'Touching' cases
    reconstruct (Exiting Vec2
start : rest :: [NormalizedCut]
rest@(Entering Vec2
end : [NormalizedCut]
_)) = (Vec2 -> Vec2 -> Line
Line Vec2
start Vec2
end, LineType
LineOutsidePolygon) (Line, LineType) -> [(Line, LineType)] -> [(Line, LineType)]
forall a. a -> [a] -> [a]
: [NormalizedCut] -> [(Line, LineType)]
reconstruct [NormalizedCut]
rest
    reconstruct (e :: NormalizedCut
e@Exiting{} : AlongEdge{} : [NormalizedCut]
rest) = [NormalizedCut] -> [(Line, LineType)]
reconstruct (NormalizedCut
eNormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
:[NormalizedCut]
rest) -- We ignore the alongEdge part here, much like the 'Touching' cases
    reconstruct [Exiting{}] = []

    -- Unhappy path, cutting along edges: do some lookahead to decide whether we’re in our out
    reconstruct (AlongEdge Vec2
start Vec2
end : rest :: [NormalizedCut]
rest@(AlongEdge{} : [NormalizedCut]
_)) = (Vec2 -> Vec2 -> Line
Line Vec2
start Vec2
end, LineType
LineInsidePolygon) (Line, LineType) -> [(Line, LineType)] -> [(Line, LineType)]
forall a. a -> [a] -> [a]
: [NormalizedCut] -> [(Line, LineType)]
reconstruct [NormalizedCut]
rest
    reconstruct (AlongEdge Vec2
start Vec2
end : rest :: [NormalizedCut]
rest@(Entering{} : [NormalizedCut]
_)) = (Vec2 -> Vec2 -> Line
Line Vec2
start Vec2
end, LineType
LineOutsidePolygon) (Line, LineType) -> [(Line, LineType)] -> [(Line, LineType)]
forall a. a -> [a] -> [a]
: [NormalizedCut] -> [(Line, LineType)]
reconstruct [NormalizedCut]
rest
    reconstruct (AlongEdge Vec2
start Vec2
end : rest :: [NormalizedCut]
rest@(Exiting{} : [NormalizedCut]
_)) = (Vec2 -> Vec2 -> Line
Line Vec2
start Vec2
end, LineType
LineInsidePolygon) (Line, LineType) -> [(Line, LineType)] -> [(Line, LineType)]
forall a. a -> [a] -> [a]
: [NormalizedCut] -> [(Line, LineType)]
reconstruct [NormalizedCut]
rest
    reconstruct [AlongEdge{}] = [] -- This might also be declared an error, but in the name of sanity let’s just say this does nothing

    -- Ignore touch points: simply continue the line
    reconstruct (e :: NormalizedCut
e@Entering{} : Touching{} : [NormalizedCut]
rest) = [NormalizedCut] -> [(Line, LineType)]
reconstruct (NormalizedCut
eNormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
:[NormalizedCut]
rest)
    reconstruct (e :: NormalizedCut
e@Exiting{} : Touching{} : [NormalizedCut]
rest) = [NormalizedCut] -> [(Line, LineType)]
reconstruct (NormalizedCut
eNormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
:[NormalizedCut]
rest)
    reconstruct (along :: NormalizedCut
along@AlongEdge{} : Touching{} : [NormalizedCut]
rest) = [NormalizedCut] -> [(Line, LineType)]
reconstruct (NormalizedCut
alongNormalizedCut -> [NormalizedCut] -> [NormalizedCut]
forall a. a -> [a] -> [a]
:[NormalizedCut]
rest)
    reconstruct (Touching{} : [NormalizedCut]
rest) = [NormalizedCut] -> [(Line, LineType)]
reconstruct [NormalizedCut]
rest

    reconstruct (Entering{} : Entering {} : [NormalizedCut]
_) = String -> String -> [(Line, LineType)]
forall a. String -> String -> a
bugError String
"Cut.Internal.clipPolygonWithLine" String
"Double enter"
    reconstruct (Exiting{} : Exiting {} : [NormalizedCut]
_) = String -> String -> [(Line, LineType)]
forall a. String -> String -> a
bugError String
"Cut.Internal.clipPolygonWithLine" String
"Double exit"
    reconstruct [Entering{}] = String -> String -> [(Line, LineType)]
forall a. String -> String -> a
bugError String
"Cut.Internal.clipPolygonWithLine" String
"Standalone enter"
    reconstruct [] = [] -- Input was empty to begin with, otherwise one of the other cases happens

clipPolygonWithLineSegment :: Polygon -> Line -> [(Line, LineType)]
clipPolygonWithLineSegment :: Polygon -> Line -> [(Line, LineType)]
clipPolygonWithLineSegment Polygon
polygon scissors :: Line
scissors@(Line Vec2
start Vec2
end) = [Vec2] -> [(Line, LineType)]
reconstructSegments [Vec2]
sortedPoints
  where
    allIntersectionPoints :: [Vec2]
allIntersectionPoints =
        [ Vec2
p
        | Line
edge <- Polygon -> [Line]
polygonEdges Polygon
polygon
        , IntersectionReal Vec2
p <- LLIntersection -> [LLIntersection]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Line -> Line -> LLIntersection
intersectionLL Line
edge Line
scissors)
        ]
    sortedPoints :: [Vec2]
sortedPoints = (Vec2 -> Double) -> [Vec2] -> [Vec2]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\Vec2
p -> Line -> Vec2
direction Line
scissors Vec2 -> Vec2 -> Double
`dotProduct` (Vec2
p Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
start)) ([Vec2
start, Vec2
end] [Vec2] -> [Vec2] -> [Vec2]
forall a. [a] -> [a] -> [a]
++ [Vec2]
allIntersectionPoints)
    reconstructSegments :: [Vec2] -> [(Line, LineType)]
reconstructSegments = \case
        [] -> []
        [Vec2
_] -> []
        Vec2
a : Vec2
b : [Vec2]
xs ->
            let segment :: Line
segment = Vec2 -> Vec2 -> Line
Line Vec2
a Vec2
b
                lineType :: LineType
lineType = if ((Vec2
a Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
b) Vec2 -> Double -> Vec2
forall v. VectorSpace v => v -> Double -> v
/. Double
2) Vec2 -> Polygon -> Bool
`pointInPolygon` Polygon
polygon
                    then LineType
LineInsidePolygon
                    else LineType
LineOutsidePolygon
            in  (Line
segment, LineType
lineType) (Line, LineType) -> [(Line, LineType)] -> [(Line, LineType)]
forall a. a -> [a] -> [a]
: [Vec2] -> [(Line, LineType)]
reconstructSegments (Vec2
b Vec2 -> [Vec2] -> [Vec2]
forall a. a -> [a] -> [a]
: [Vec2]
xs)