-- | __INTERNAL MODULE__, not exposed from the package.
--
-- Binary operations on polygons (union, intersection, difference, based on a
-- fantastic paper by Margalit and Knott,
-- /An algorithm for computing the union, intersection or difference of two polygons/.
module Geometry.Algorithms.Clipping.MargalitKnott (
      IslandOrHole(..)
    , unionPP
    , intersectionPP
    , differencePP
    , antiDifferencePP
) where



import Control.Monad.State
import Data.List

import           Data.Multwomap (Multwomap)
import qualified Data.Multwomap as MM
import           Geometry.Core

-- $setup
-- >>> import Draw
-- >>> import Graphics.Rendering.Cairo


data Operation
    = Union
    | Intersection
    | Difference -- ^ A-B
    | AntiDifference -- ^ B-A
    deriving (Operation -> Operation -> Bool
(Operation -> Operation -> Bool)
-> (Operation -> Operation -> Bool) -> Eq Operation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Operation -> Operation -> Bool
== :: Operation -> Operation -> Bool
$c/= :: Operation -> Operation -> Bool
/= :: Operation -> Operation -> Bool
Eq, Eq Operation
Eq Operation
-> (Operation -> Operation -> Ordering)
-> (Operation -> Operation -> Bool)
-> (Operation -> Operation -> Bool)
-> (Operation -> Operation -> Bool)
-> (Operation -> Operation -> Bool)
-> (Operation -> Operation -> Operation)
-> (Operation -> Operation -> Operation)
-> Ord Operation
Operation -> Operation -> Bool
Operation -> Operation -> Ordering
Operation -> Operation -> Operation
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 :: Operation -> Operation -> Ordering
compare :: Operation -> Operation -> Ordering
$c< :: Operation -> Operation -> Bool
< :: Operation -> Operation -> Bool
$c<= :: Operation -> Operation -> Bool
<= :: Operation -> Operation -> Bool
$c> :: Operation -> Operation -> Bool
> :: Operation -> Operation -> Bool
$c>= :: Operation -> Operation -> Bool
>= :: Operation -> Operation -> Bool
$cmax :: Operation -> Operation -> Operation
max :: Operation -> Operation -> Operation
$cmin :: Operation -> Operation -> Operation
min :: Operation -> Operation -> Operation
Ord, Int -> Operation -> ShowS
[Operation] -> ShowS
Operation -> String
(Int -> Operation -> ShowS)
-> (Operation -> String)
-> ([Operation] -> ShowS)
-> Show Operation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Operation -> ShowS
showsPrec :: Int -> Operation -> ShowS
$cshow :: Operation -> String
show :: Operation -> String
$cshowList :: [Operation] -> ShowS
showList :: [Operation] -> ShowS
Show)

-- | Type of polygons, used to distinguish results of polygon clipping.
data IslandOrHole
    = Island -- ^ An ordinary polygon. It has finite interior and infinite exterior area.
    | Hole -- ^ A hole has a finite exterior, and infinite interior.
    deriving (IslandOrHole -> IslandOrHole -> Bool
(IslandOrHole -> IslandOrHole -> Bool)
-> (IslandOrHole -> IslandOrHole -> Bool) -> Eq IslandOrHole
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IslandOrHole -> IslandOrHole -> Bool
== :: IslandOrHole -> IslandOrHole -> Bool
$c/= :: IslandOrHole -> IslandOrHole -> Bool
/= :: IslandOrHole -> IslandOrHole -> Bool
Eq, Eq IslandOrHole
Eq IslandOrHole
-> (IslandOrHole -> IslandOrHole -> Ordering)
-> (IslandOrHole -> IslandOrHole -> Bool)
-> (IslandOrHole -> IslandOrHole -> Bool)
-> (IslandOrHole -> IslandOrHole -> Bool)
-> (IslandOrHole -> IslandOrHole -> Bool)
-> (IslandOrHole -> IslandOrHole -> IslandOrHole)
-> (IslandOrHole -> IslandOrHole -> IslandOrHole)
-> Ord IslandOrHole
IslandOrHole -> IslandOrHole -> Bool
IslandOrHole -> IslandOrHole -> Ordering
IslandOrHole -> IslandOrHole -> IslandOrHole
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 :: IslandOrHole -> IslandOrHole -> Ordering
compare :: IslandOrHole -> IslandOrHole -> Ordering
$c< :: IslandOrHole -> IslandOrHole -> Bool
< :: IslandOrHole -> IslandOrHole -> Bool
$c<= :: IslandOrHole -> IslandOrHole -> Bool
<= :: IslandOrHole -> IslandOrHole -> Bool
$c> :: IslandOrHole -> IslandOrHole -> Bool
> :: IslandOrHole -> IslandOrHole -> Bool
$c>= :: IslandOrHole -> IslandOrHole -> Bool
>= :: IslandOrHole -> IslandOrHole -> Bool
$cmax :: IslandOrHole -> IslandOrHole -> IslandOrHole
max :: IslandOrHole -> IslandOrHole -> IslandOrHole
$cmin :: IslandOrHole -> IslandOrHole -> IslandOrHole
min :: IslandOrHole -> IslandOrHole -> IslandOrHole
Ord, Int -> IslandOrHole -> ShowS
[IslandOrHole] -> ShowS
IslandOrHole -> String
(Int -> IslandOrHole -> ShowS)
-> (IslandOrHole -> String)
-> ([IslandOrHole] -> ShowS)
-> Show IslandOrHole
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IslandOrHole -> ShowS
showsPrec :: Int -> IslandOrHole -> ShowS
$cshow :: IslandOrHole -> String
show :: IslandOrHole -> String
$cshowList :: [IslandOrHole] -> ShowS
showList :: [IslandOrHole] -> ShowS
Show)

data RelativeOrientation = SameOrientation | OppositeOrientation deriving (RelativeOrientation -> RelativeOrientation -> Bool
(RelativeOrientation -> RelativeOrientation -> Bool)
-> (RelativeOrientation -> RelativeOrientation -> Bool)
-> Eq RelativeOrientation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RelativeOrientation -> RelativeOrientation -> Bool
== :: RelativeOrientation -> RelativeOrientation -> Bool
$c/= :: RelativeOrientation -> RelativeOrientation -> Bool
/= :: RelativeOrientation -> RelativeOrientation -> Bool
Eq, Eq RelativeOrientation
Eq RelativeOrientation
-> (RelativeOrientation -> RelativeOrientation -> Ordering)
-> (RelativeOrientation -> RelativeOrientation -> Bool)
-> (RelativeOrientation -> RelativeOrientation -> Bool)
-> (RelativeOrientation -> RelativeOrientation -> Bool)
-> (RelativeOrientation -> RelativeOrientation -> Bool)
-> (RelativeOrientation
    -> RelativeOrientation -> RelativeOrientation)
-> (RelativeOrientation
    -> RelativeOrientation -> RelativeOrientation)
-> Ord RelativeOrientation
RelativeOrientation -> RelativeOrientation -> Bool
RelativeOrientation -> RelativeOrientation -> Ordering
RelativeOrientation -> RelativeOrientation -> RelativeOrientation
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 :: RelativeOrientation -> RelativeOrientation -> Ordering
compare :: RelativeOrientation -> RelativeOrientation -> Ordering
$c< :: RelativeOrientation -> RelativeOrientation -> Bool
< :: RelativeOrientation -> RelativeOrientation -> Bool
$c<= :: RelativeOrientation -> RelativeOrientation -> Bool
<= :: RelativeOrientation -> RelativeOrientation -> Bool
$c> :: RelativeOrientation -> RelativeOrientation -> Bool
> :: RelativeOrientation -> RelativeOrientation -> Bool
$c>= :: RelativeOrientation -> RelativeOrientation -> Bool
>= :: RelativeOrientation -> RelativeOrientation -> Bool
$cmax :: RelativeOrientation -> RelativeOrientation -> RelativeOrientation
max :: RelativeOrientation -> RelativeOrientation -> RelativeOrientation
$cmin :: RelativeOrientation -> RelativeOrientation -> RelativeOrientation
min :: RelativeOrientation -> RelativeOrientation -> RelativeOrientation
Ord, Int -> RelativeOrientation -> ShowS
[RelativeOrientation] -> ShowS
RelativeOrientation -> String
(Int -> RelativeOrientation -> ShowS)
-> (RelativeOrientation -> String)
-> ([RelativeOrientation] -> ShowS)
-> Show RelativeOrientation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RelativeOrientation -> ShowS
showsPrec :: Int -> RelativeOrientation -> ShowS
$cshow :: RelativeOrientation -> String
show :: RelativeOrientation -> String
$cshowList :: [RelativeOrientation] -> ShowS
showList :: [RelativeOrientation] -> ShowS
Show)

data Side = Inside | Outside | Boundary deriving (Side -> Side -> Bool
(Side -> Side -> Bool) -> (Side -> Side -> Bool) -> Eq Side
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Side -> Side -> Bool
== :: Side -> Side -> Bool
$c/= :: Side -> Side -> Bool
/= :: Side -> Side -> Bool
Eq, Eq Side
Eq Side
-> (Side -> Side -> Ordering)
-> (Side -> Side -> Bool)
-> (Side -> Side -> Bool)
-> (Side -> Side -> Bool)
-> (Side -> Side -> Bool)
-> (Side -> Side -> Side)
-> (Side -> Side -> Side)
-> Ord Side
Side -> Side -> Bool
Side -> Side -> Ordering
Side -> Side -> Side
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 :: Side -> Side -> Ordering
compare :: Side -> Side -> Ordering
$c< :: Side -> Side -> Bool
< :: Side -> Side -> Bool
$c<= :: Side -> Side -> Bool
<= :: Side -> Side -> Bool
$c> :: Side -> Side -> Bool
> :: Side -> Side -> Bool
$c>= :: Side -> Side -> Bool
>= :: Side -> Side -> Bool
$cmax :: Side -> Side -> Side
max :: Side -> Side -> Side
$cmin :: Side -> Side -> Side
min :: Side -> Side -> Side
Ord, Int -> Side -> ShowS
[Side] -> ShowS
Side -> String
(Int -> Side -> ShowS)
-> (Side -> String) -> ([Side] -> ShowS) -> Show Side
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Side -> ShowS
showsPrec :: Int -> Side -> ShowS
$cshow :: Side -> String
show :: Side -> String
$cshowList :: [Side] -> ShowS
showList :: [Side] -> ShowS
Show)

-- | Let’s only deal with regular polygons for now. Or wait, are regular polygons
-- the more complicated option because they require regularization? In any case,
-- this will only become important once more pathological polygons are accepted as
-- inputs.
data Regularity = Regular deriving (Regularity -> Regularity -> Bool
(Regularity -> Regularity -> Bool)
-> (Regularity -> Regularity -> Bool) -> Eq Regularity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Regularity -> Regularity -> Bool
== :: Regularity -> Regularity -> Bool
$c/= :: Regularity -> Regularity -> Bool
/= :: Regularity -> Regularity -> Bool
Eq, Eq Regularity
Eq Regularity
-> (Regularity -> Regularity -> Ordering)
-> (Regularity -> Regularity -> Bool)
-> (Regularity -> Regularity -> Bool)
-> (Regularity -> Regularity -> Bool)
-> (Regularity -> Regularity -> Bool)
-> (Regularity -> Regularity -> Regularity)
-> (Regularity -> Regularity -> Regularity)
-> Ord Regularity
Regularity -> Regularity -> Bool
Regularity -> Regularity -> Ordering
Regularity -> Regularity -> Regularity
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 :: Regularity -> Regularity -> Ordering
compare :: Regularity -> Regularity -> Ordering
$c< :: Regularity -> Regularity -> Bool
< :: Regularity -> Regularity -> Bool
$c<= :: Regularity -> Regularity -> Bool
<= :: Regularity -> Regularity -> Bool
$c> :: Regularity -> Regularity -> Bool
> :: Regularity -> Regularity -> Bool
$c>= :: Regularity -> Regularity -> Bool
>= :: Regularity -> Regularity -> Bool
$cmax :: Regularity -> Regularity -> Regularity
max :: Regularity -> Regularity -> Regularity
$cmin :: Regularity -> Regularity -> Regularity
min :: Regularity -> Regularity -> Regularity
Ord, Int -> Regularity -> ShowS
[Regularity] -> ShowS
Regularity -> String
(Int -> Regularity -> ShowS)
-> (Regularity -> String)
-> ([Regularity] -> ShowS)
-> Show Regularity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Regularity -> ShowS
showsPrec :: Int -> Regularity -> ShowS
$cshow :: Regularity -> String
show :: Regularity -> String
$cshowList :: [Regularity] -> ShowS
showList :: [Regularity] -> ShowS
Show)

-- | > Procedure 'changeOrientation' changes the orientation of the polygon Polygon.
changeOrientation :: Polygon -> Polygon
changeOrientation :: Polygon -> Polygon
changeOrientation (Polygon [Vec2]
ps) = [Vec2] -> Polygon
Polygon ([Vec2] -> [Vec2]
forall a. [a] -> [a]
reverse [Vec2]
ps)

-- |
-- > Table @polygonsOrientation[polygon-A-type][polygon-B-type][Oper]@ contains
-- > indicators which specify whether the two input polygons should have the same or
-- > opposite orientations according to the operation and the polygon types (table 1)
polygonsOrientation :: IslandOrHole -> IslandOrHole -> Operation -> RelativeOrientation
polygonsOrientation :: IslandOrHole -> IslandOrHole -> Operation -> RelativeOrientation
polygonsOrientation IslandOrHole
Island IslandOrHole
Island Operation
Intersection   = RelativeOrientation
SameOrientation
polygonsOrientation IslandOrHole
Island IslandOrHole
Island Operation
Union          = RelativeOrientation
SameOrientation
polygonsOrientation IslandOrHole
Island IslandOrHole
Island Operation
Difference     = RelativeOrientation
OppositeOrientation
polygonsOrientation IslandOrHole
Island IslandOrHole
Island Operation
AntiDifference = RelativeOrientation
OppositeOrientation

polygonsOrientation IslandOrHole
Island IslandOrHole
Hole Operation
Intersection     = RelativeOrientation
OppositeOrientation
polygonsOrientation IslandOrHole
Island IslandOrHole
Hole Operation
Union            = RelativeOrientation
OppositeOrientation
polygonsOrientation IslandOrHole
Island IslandOrHole
Hole Operation
Difference       = RelativeOrientation
SameOrientation
polygonsOrientation IslandOrHole
Island IslandOrHole
Hole Operation
AntiDifference   = RelativeOrientation
SameOrientation

polygonsOrientation IslandOrHole
Hole IslandOrHole
Island Operation
Intersection     = RelativeOrientation
OppositeOrientation
polygonsOrientation IslandOrHole
Hole IslandOrHole
Island Operation
Union            = RelativeOrientation
OppositeOrientation
polygonsOrientation IslandOrHole
Hole IslandOrHole
Island Operation
Difference       = RelativeOrientation
SameOrientation
polygonsOrientation IslandOrHole
Hole IslandOrHole
Island Operation
AntiDifference   = RelativeOrientation
SameOrientation

polygonsOrientation IslandOrHole
Hole IslandOrHole
Hole Operation
Intersection       = RelativeOrientation
SameOrientation
polygonsOrientation IslandOrHole
Hole IslandOrHole
Hole Operation
Union              = RelativeOrientation
SameOrientation
polygonsOrientation IslandOrHole
Hole IslandOrHole
Hole Operation
Difference         = RelativeOrientation
OppositeOrientation
polygonsOrientation IslandOrHole
Hole IslandOrHole
Hole Operation
AntiDifference     = RelativeOrientation
OppositeOrientation

-- |
-- > Table @fragmentype[polygon-A-type][polygon-B-type][Oper][polygon]@ contains the
-- > type of edge fragments, besides the boundary line fragments, to be selected
-- > for insertion into the line fragments table according to the operation and the
-- > polygon types (Table 2).
fragmentType :: IslandOrHole -> IslandOrHole -> Operation -> (Side, Side)
fragmentType :: IslandOrHole -> IslandOrHole -> Operation -> (Side, Side)
fragmentType IslandOrHole
Island IslandOrHole
Island Operation
Intersection   = (Side
Inside, Side
Inside)
fragmentType IslandOrHole
Island IslandOrHole
Island Operation
Union          = (Side
Outside, Side
Outside)
fragmentType IslandOrHole
Island IslandOrHole
Island Operation
Difference     = (Side
Outside, Side
Inside)
fragmentType IslandOrHole
Island IslandOrHole
Island Operation
AntiDifference = (Side
Inside, Side
Outside)

fragmentType IslandOrHole
Island IslandOrHole
Hole Operation
Intersection     = (Side
Outside, Side
Inside)
fragmentType IslandOrHole
Island IslandOrHole
Hole Operation
Union            = (Side
Inside, Side
Outside)
fragmentType IslandOrHole
Island IslandOrHole
Hole Operation
Difference       = (Side
Inside, Side
Inside)
fragmentType IslandOrHole
Island IslandOrHole
Hole Operation
AntiDifference   = (Side
Outside, Side
Outside)

fragmentType IslandOrHole
Hole IslandOrHole
Island Operation
Intersection     = (Side
Inside, Side
Outside)
fragmentType IslandOrHole
Hole IslandOrHole
Island Operation
Union            = (Side
Outside, Side
Inside)
fragmentType IslandOrHole
Hole IslandOrHole
Island Operation
Difference       = (Side
Outside, Side
Outside)
fragmentType IslandOrHole
Hole IslandOrHole
Island Operation
AntiDifference   = (Side
Inside, Side
Inside)

fragmentType IslandOrHole
Hole IslandOrHole
Hole Operation
Intersection       = (Side
Outside, Side
Outside)
fragmentType IslandOrHole
Hole IslandOrHole
Hole Operation
Union              = (Side
Inside, Side
Inside)
fragmentType IslandOrHole
Hole IslandOrHole
Hole Operation
Difference         = (Side
Inside, Side
Outside)
fragmentType IslandOrHole
Hole IslandOrHole
Hole Operation
AntiDifference     = (Side
Outside, Side
Inside)


data EdgeDirection
    = EdCo -- ^ In the paper: -->
    | EdAnti -- ^ In the paper: <--
    | EoAny -- ^ -- ^ In the paper: <--/-->
    deriving (EdgeDirection -> EdgeDirection -> Bool
(EdgeDirection -> EdgeDirection -> Bool)
-> (EdgeDirection -> EdgeDirection -> Bool) -> Eq EdgeDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeDirection -> EdgeDirection -> Bool
== :: EdgeDirection -> EdgeDirection -> Bool
$c/= :: EdgeDirection -> EdgeDirection -> Bool
/= :: EdgeDirection -> EdgeDirection -> Bool
Eq, Eq EdgeDirection
Eq EdgeDirection
-> (EdgeDirection -> EdgeDirection -> Ordering)
-> (EdgeDirection -> EdgeDirection -> Bool)
-> (EdgeDirection -> EdgeDirection -> Bool)
-> (EdgeDirection -> EdgeDirection -> Bool)
-> (EdgeDirection -> EdgeDirection -> Bool)
-> (EdgeDirection -> EdgeDirection -> EdgeDirection)
-> (EdgeDirection -> EdgeDirection -> EdgeDirection)
-> Ord EdgeDirection
EdgeDirection -> EdgeDirection -> Bool
EdgeDirection -> EdgeDirection -> Ordering
EdgeDirection -> EdgeDirection -> EdgeDirection
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 :: EdgeDirection -> EdgeDirection -> Ordering
compare :: EdgeDirection -> EdgeDirection -> Ordering
$c< :: EdgeDirection -> EdgeDirection -> Bool
< :: EdgeDirection -> EdgeDirection -> Bool
$c<= :: EdgeDirection -> EdgeDirection -> Bool
<= :: EdgeDirection -> EdgeDirection -> Bool
$c> :: EdgeDirection -> EdgeDirection -> Bool
> :: EdgeDirection -> EdgeDirection -> Bool
$c>= :: EdgeDirection -> EdgeDirection -> Bool
>= :: EdgeDirection -> EdgeDirection -> Bool
$cmax :: EdgeDirection -> EdgeDirection -> EdgeDirection
max :: EdgeDirection -> EdgeDirection -> EdgeDirection
$cmin :: EdgeDirection -> EdgeDirection -> EdgeDirection
min :: EdgeDirection -> EdgeDirection -> EdgeDirection
Ord, Int -> EdgeDirection -> ShowS
[EdgeDirection] -> ShowS
EdgeDirection -> String
(Int -> EdgeDirection -> ShowS)
-> (EdgeDirection -> String)
-> ([EdgeDirection] -> ShowS)
-> Show EdgeDirection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EdgeDirection -> ShowS
showsPrec :: Int -> EdgeDirection -> ShowS
$cshow :: EdgeDirection -> String
show :: EdgeDirection -> String
$cshowList :: [EdgeDirection] -> ShowS
showList :: [EdgeDirection] -> ShowS
Show)

--   -- | This table is a huge WTF :-E
--   --
--   -- @boundaryFragment[polygon-A-type][polygon-B-type][situation][Oper][regularity]@
--   -- contains indicators which specifies how many boundary edge fragments are to be
--   -- selected given the edge fragments situation for regular and non-regular
--   -- operations.
--   boundaryFragment
--       :: (IslandOrHole, EdgeDirection)
--       -> (IslandOrHole, EdgeDirection)
--       -> Operation
--       -> Regularity
--       -> Maybe EdgeDirection
--   -- The one sane case: agreeing edges keep agreeing. Hooray!
--   boundaryFragment (_, EdCo) (_, EdCo) _ _ = Just EdCo
--   -- Island/island regular
--   boundaryFragment (Island, EdCo)  (Island, EoAny) Union          Regular = Just EdCo
--   boundaryFragment (Island, EdCo)  (Island, EoAny) Difference     Regular = Just EdCo
--   boundaryFragment (Island, EoAny) (Island, EdCo)  Union          Regular = Just EdCo
--   boundaryFragment (Island, EoAny) (Island, EdCo)  AntiDifference Regular = Just EdCo
--   -- Island/hole, regular
--   boundaryFragment (Island, EdCo)  (Hole,   EoAny) Intersection   Regular = Just EdCo
--   boundaryFragment (Island, EdCo)  (Hole,   EoAny) AntiDifference Regular = Just EdCo
--   boundaryFragment (Island, EoAny) (Hole,   EdCo)  Union          Regular = Just EdCo
--   boundaryFragment (Island, EoAny) (Hole,   EdCo)  Difference     Regular = Just EdCo
--   -- Hole/island, regular
--   boundaryFragment (Hole,   EdCo)  (Island, EoAny) Union          Regular = Just EdCo
--   boundaryFragment (Hole,   EdCo)  (Island, EoAny) Difference     Regular = Just EdCo
--   boundaryFragment (Hole,   EoAny) (Island, EdCo)  Intersection   Regular = Just EdCo
--   boundaryFragment (Hole,   EoAny) (Island, EdCo)  Difference     Regular = Just EdCo
--   -- Hole/hole, regular
--   boundaryFragment (Hole,   EdCo)  (Hole,   EoAny) Intersection   Regular = Just EdCo
--   boundaryFragment (Hole,   EdCo)  (Hole,   EoAny) AntiDifference Regular = Just EdCo
--   boundaryFragment (Hole,   EoAny) (Hole,   EdCo)  Intersection   Regular = Just EdCo
--   boundaryFragment (Hole,   EoAny) (Hole,   EdCo)  Difference     Regular = Just EdCo
--   -- All other cases don’t yield results
--   boundaryFragment _ _ _ Regular = Nothing

-- |
-- Table @resultOrientation[polygon-A-type][polygon-B-type][Oper]@ contains
-- indicators which specify whether the type of an output result polygon is the
-- same as or the opposite of the type of polygon A when both have the same
-- orientation. If they have the opposite orientations, the orientation of the
-- result polygon is the opposite of what is written in the table.
resultOrientation :: IslandOrHole -> IslandOrHole -> Operation -> RelativeOrientation
resultOrientation :: IslandOrHole -> IslandOrHole -> Operation -> RelativeOrientation
resultOrientation IslandOrHole
Island IslandOrHole
Island Operation
Intersection   = RelativeOrientation
SameOrientation
resultOrientation IslandOrHole
Island IslandOrHole
Island Operation
Union          = RelativeOrientation
SameOrientation
resultOrientation IslandOrHole
Island IslandOrHole
Island Operation
Difference     = RelativeOrientation
SameOrientation
resultOrientation IslandOrHole
Island IslandOrHole
Island Operation
AntiDifference = RelativeOrientation
OppositeOrientation

resultOrientation IslandOrHole
Island IslandOrHole
Hole Operation
Intersection     = RelativeOrientation
SameOrientation
resultOrientation IslandOrHole
Island IslandOrHole
Hole Operation
Union            = RelativeOrientation
OppositeOrientation
resultOrientation IslandOrHole
Island IslandOrHole
Hole Operation
Difference       = RelativeOrientation
SameOrientation
resultOrientation IslandOrHole
Island IslandOrHole
Hole Operation
AntiDifference   = RelativeOrientation
SameOrientation

resultOrientation IslandOrHole
Hole IslandOrHole
Island Operation
Intersection     = RelativeOrientation
OppositeOrientation
resultOrientation IslandOrHole
Hole IslandOrHole
Island Operation
Union            = RelativeOrientation
SameOrientation
resultOrientation IslandOrHole
Hole IslandOrHole
Island Operation
Difference       = RelativeOrientation
SameOrientation
resultOrientation IslandOrHole
Hole IslandOrHole
Island Operation
AntiDifference   = RelativeOrientation
SameOrientation

resultOrientation IslandOrHole
Hole IslandOrHole
Hole Operation
Intersection       = RelativeOrientation
SameOrientation
resultOrientation IslandOrHole
Hole IslandOrHole
Hole Operation
Union              = RelativeOrientation
SameOrientation
resultOrientation IslandOrHole
Hole IslandOrHole
Hole Operation
Difference         = RelativeOrientation
OppositeOrientation
resultOrientation IslandOrHole
Hole IslandOrHole
Hole Operation
AntiDifference     = RelativeOrientation
SameOrientation

-- | Change the orientation of B so it works for the operation with A.
orientB
    :: Operation
    -> Polygon      -- ^ A
    -> Polygon      -- ^ B
    -> IslandOrHole -- ^ A’s type
    -> IslandOrHole -- ^ B’s type
    -> Polygon      -- ^ B, with possibly inverted orientation
orientB :: Operation
-> Polygon -> Polygon -> IslandOrHole -> IslandOrHole -> Polygon
orientB Operation
op Polygon
polygonA Polygon
polygonB IslandOrHole
typeA IslandOrHole
typeB =
    let orientationA :: PolygonOrientation
orientationA = Polygon -> PolygonOrientation
polygonOrientation Polygon
polygonA
        orientationB :: PolygonOrientation
orientationB = Polygon -> PolygonOrientation
polygonOrientation Polygon
polygonB
    in case IslandOrHole -> IslandOrHole -> Operation -> RelativeOrientation
polygonsOrientation IslandOrHole
typeA IslandOrHole
typeB Operation
op of
        RelativeOrientation
SameOrientation | PolygonOrientation
orientationA PolygonOrientation -> PolygonOrientation -> Bool
forall a. Eq a => a -> a -> Bool
/= PolygonOrientation
orientationB -> Polygon -> Polygon
changeOrientation Polygon
polygonB
        RelativeOrientation
OppositeOrientation | PolygonOrientation
orientationA PolygonOrientation -> PolygonOrientation -> Bool
forall a. Eq a => a -> a -> Bool
== PolygonOrientation
orientationB -> Polygon -> Polygon
changeOrientation Polygon
polygonB
        RelativeOrientation
_otherwise -> Polygon
polygonB

data CutEdge = CutEdge Vec2 [Vec2] Vec2
    deriving (CutEdge -> CutEdge -> Bool
(CutEdge -> CutEdge -> Bool)
-> (CutEdge -> CutEdge -> Bool) -> Eq CutEdge
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CutEdge -> CutEdge -> Bool
== :: CutEdge -> CutEdge -> Bool
$c/= :: CutEdge -> CutEdge -> Bool
/= :: CutEdge -> CutEdge -> Bool
Eq, Eq CutEdge
Eq CutEdge
-> (CutEdge -> CutEdge -> Ordering)
-> (CutEdge -> CutEdge -> Bool)
-> (CutEdge -> CutEdge -> Bool)
-> (CutEdge -> CutEdge -> Bool)
-> (CutEdge -> CutEdge -> Bool)
-> (CutEdge -> CutEdge -> CutEdge)
-> (CutEdge -> CutEdge -> CutEdge)
-> Ord CutEdge
CutEdge -> CutEdge -> Bool
CutEdge -> CutEdge -> Ordering
CutEdge -> CutEdge -> CutEdge
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 :: CutEdge -> CutEdge -> Ordering
compare :: CutEdge -> CutEdge -> Ordering
$c< :: CutEdge -> CutEdge -> Bool
< :: CutEdge -> CutEdge -> Bool
$c<= :: CutEdge -> CutEdge -> Bool
<= :: CutEdge -> CutEdge -> Bool
$c> :: CutEdge -> CutEdge -> Bool
> :: CutEdge -> CutEdge -> Bool
$c>= :: CutEdge -> CutEdge -> Bool
>= :: CutEdge -> CutEdge -> Bool
$cmax :: CutEdge -> CutEdge -> CutEdge
max :: CutEdge -> CutEdge -> CutEdge
$cmin :: CutEdge -> CutEdge -> CutEdge
min :: CutEdge -> CutEdge -> CutEdge
Ord, Int -> CutEdge -> ShowS
[CutEdge] -> ShowS
CutEdge -> String
(Int -> CutEdge -> ShowS)
-> (CutEdge -> String) -> ([CutEdge] -> ShowS) -> Show CutEdge
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CutEdge -> ShowS
showsPrec :: Int -> CutEdge -> ShowS
$cshow :: CutEdge -> String
show :: CutEdge -> String
$cshowList :: [CutEdge] -> ShowS
showList :: [CutEdge] -> ShowS
Show)

cutPolygonEdges
    :: Polygon -- ^ Subject
    -> Polygon -- ^ Knives
    -> [CutEdge]
        -- ^ Subject’s edges, extended with intersection points. Note that each
        -- subject corner appears twice, once as end, and once as start of a
        -- 'CutEdge'.
cutPolygonEdges :: Polygon -> Polygon -> [CutEdge]
cutPolygonEdges Polygon
subject Polygon
knives = do
    edge :: Line
edge@(Line Vec2
start Vec2
end) <- Polygon -> [Line]
polygonEdges Polygon
subject
    let cuts :: [Vec2]
cuts = (Vec2 -> Double) -> [Vec2] -> [Vec2]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\Vec2
x -> Vec2 -> Line -> Double
positionAlongEdge Vec2
x Line
edge) (Line -> [Line] -> [Vec2]
multiCutLine Line
edge (Polygon -> [Line]
polygonEdges Polygon
knives))
    CutEdge -> [CutEdge]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vec2 -> [Vec2] -> Vec2 -> CutEdge
CutEdge Vec2
start [Vec2]
cuts Vec2
end)

-- | Cut a line with multiple knives, and report the intersection points in order
-- along the edge.
multiCutLine :: Line -> [Line] -> [Vec2]
multiCutLine :: Line -> [Line] -> [Vec2]
multiCutLine Line
edge [Line]
knives = [Vec2
x | IntersectionReal Vec2
x <- (Line -> LLIntersection) -> [Line] -> [LLIntersection]
forall a b. (a -> b) -> [a] -> [b]
map (Line -> Line -> LLIntersection
intersectionLL Line
edge) [Line]
knives]

-- Position of a point on a line relative to the line’s start in arbitrary units.
-- Useful for sorting.
positionAlongEdge :: Vec2 -> Line -> Double
positionAlongEdge :: Vec2 -> Line -> Double
positionAlongEdge Vec2
p edge :: Line
edge@(Line Vec2
edgeStart Vec2
_) = Vec2 -> Vec2 -> Double
dotProduct (Line -> Vec2
vectorOf Line
edge) (Line -> Vec2
vectorOf (Vec2 -> Vec2 -> Line
Line Vec2
edgeStart Vec2
p))

-- | Polygon, annotated with where the points lie with respect to another polygon.
newtype CutPolygon = CutPolygon [(Side, Vec2)] deriving (CutPolygon -> CutPolygon -> Bool
(CutPolygon -> CutPolygon -> Bool)
-> (CutPolygon -> CutPolygon -> Bool) -> Eq CutPolygon
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CutPolygon -> CutPolygon -> Bool
== :: CutPolygon -> CutPolygon -> Bool
$c/= :: CutPolygon -> CutPolygon -> Bool
/= :: CutPolygon -> CutPolygon -> Bool
Eq, Eq CutPolygon
Eq CutPolygon
-> (CutPolygon -> CutPolygon -> Ordering)
-> (CutPolygon -> CutPolygon -> Bool)
-> (CutPolygon -> CutPolygon -> Bool)
-> (CutPolygon -> CutPolygon -> Bool)
-> (CutPolygon -> CutPolygon -> Bool)
-> (CutPolygon -> CutPolygon -> CutPolygon)
-> (CutPolygon -> CutPolygon -> CutPolygon)
-> Ord CutPolygon
CutPolygon -> CutPolygon -> Bool
CutPolygon -> CutPolygon -> Ordering
CutPolygon -> CutPolygon -> CutPolygon
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 :: CutPolygon -> CutPolygon -> Ordering
compare :: CutPolygon -> CutPolygon -> Ordering
$c< :: CutPolygon -> CutPolygon -> Bool
< :: CutPolygon -> CutPolygon -> Bool
$c<= :: CutPolygon -> CutPolygon -> Bool
<= :: CutPolygon -> CutPolygon -> Bool
$c> :: CutPolygon -> CutPolygon -> Bool
> :: CutPolygon -> CutPolygon -> Bool
$c>= :: CutPolygon -> CutPolygon -> Bool
>= :: CutPolygon -> CutPolygon -> Bool
$cmax :: CutPolygon -> CutPolygon -> CutPolygon
max :: CutPolygon -> CutPolygon -> CutPolygon
$cmin :: CutPolygon -> CutPolygon -> CutPolygon
min :: CutPolygon -> CutPolygon -> CutPolygon
Ord, Int -> CutPolygon -> ShowS
[CutPolygon] -> ShowS
CutPolygon -> String
(Int -> CutPolygon -> ShowS)
-> (CutPolygon -> String)
-> ([CutPolygon] -> ShowS)
-> Show CutPolygon
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CutPolygon -> ShowS
showsPrec :: Int -> CutPolygon -> ShowS
$cshow :: CutPolygon -> String
show :: CutPolygon -> String
$cshowList :: [CutPolygon] -> ShowS
showList :: [CutPolygon] -> ShowS
Show)

cutPolygon :: Polygon -> Polygon -> CutPolygon
cutPolygon :: Polygon -> Polygon -> CutPolygon
cutPolygon Polygon
subject Polygon
knives = [CutEdge] -> CutPolygon
toVertexRing (Polygon -> Polygon -> [CutEdge]
cutPolygonEdges Polygon
subject Polygon
knives)
  where
    toVertexRing :: [CutEdge] -> CutPolygon
    toVertexRing :: [CutEdge] -> CutPolygon
toVertexRing [CutEdge]
cutEdges =
        let go :: [CutEdge] -> [(Side, Vec2)]
go [] = []
            go (CutEdge Vec2
start [Vec2]
cuts Vec2
_end : [CutEdge]
rest) = (Vec2 -> Polygon -> Side
pointInPolygonOrBoundary Vec2
start Polygon
knives, Vec2
start) (Side, Vec2) -> [(Side, Vec2)] -> [(Side, Vec2)]
forall a. a -> [a] -> [a]
: [(Side
Boundary, Vec2
p) | Vec2
p <- [Vec2]
cuts] [(Side, Vec2)] -> [(Side, Vec2)] -> [(Side, Vec2)]
forall a. [a] -> [a] -> [a]
++ [CutEdge] -> [(Side, Vec2)]
go [CutEdge]
rest
                               --  ^^^^ end will be handled as the start of the next cut
        in [(Side, Vec2)] -> CutPolygon
CutPolygon ([CutEdge] -> [(Side, Vec2)]
go [CutEdge]
cutEdges)

pointInPolygonOrBoundary :: Vec2 -> Polygon -> Side
pointInPolygonOrBoundary :: Vec2 -> Polygon -> Side
pointInPolygonOrBoundary Vec2
p Polygon
polygon = if Vec2 -> Polygon -> Bool
pointInPolygon Vec2
p Polygon
polygon
    then Side
Inside
    else Side
Outside -- TODO: implement point-is-on-boundary!

buildEdgeFragementMap :: CutPolygon -> Side -> Polygon -> Multwomap Vec2 Vec2
buildEdgeFragementMap :: CutPolygon -> Side -> Polygon -> Multwomap Vec2 Vec2
buildEdgeFragementMap (CutPolygon [(Side, Vec2)]
vr) Side
ty Polygon
polygonOther =
    let insertEdgeFragement :: (Side, Vec2) -> (Side, Vec2) -> Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2
        insertEdgeFragement :: (Side, Vec2)
-> (Side, Vec2) -> Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2
insertEdgeFragement (Side
Boundary, Vec2
x) (Side
Boundary, Vec2
y) = case Vec2 -> Polygon -> Side
pointInPolygonOrBoundary ((Vec2
x Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
y) Vec2 -> Double -> Vec2
forall v. VectorSpace v => v -> Double -> v
/. Double
2) Polygon
polygonOther of
            Side
Boundary -> Vec2 -> Vec2 -> Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2
forall k v. Ord k => k -> v -> Multwomap k v -> Multwomap k v
MM.insert Vec2
x Vec2
y
            Side
inOrOut | Side
inOrOut Side -> Side -> Bool
forall a. Eq a => a -> a -> Bool
== Side
ty -> Vec2 -> Vec2 -> Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2
forall k v. Ord k => k -> v -> Multwomap k v -> Multwomap k v
MM.insert Vec2
x Vec2
y
            Side
_otherwise -> Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2
forall a. a -> a
id
        insertEdgeFragement (Side
pointSideX, Vec2
x) (Side
pointSideY, Vec2
y)
            | Side
ty Side -> Side -> Bool
forall a. Eq a => a -> a -> Bool
== Side
pointSideX Bool -> Bool -> Bool
|| Side
ty Side -> Side -> Bool
forall a. Eq a => a -> a -> Bool
== Side
pointSideY = Vec2 -> Vec2 -> Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2
forall k v. Ord k => k -> v -> Multwomap k v -> Multwomap k v
MM.insert Vec2
x Vec2
y
        insertEdgeFragement (Side, Vec2)
_other (Side, Vec2)
_wise = Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2
forall a. a -> a
id

        inserts :: [Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2]
inserts = ((Side, Vec2)
 -> (Side, Vec2) -> Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2)
-> [(Side, Vec2)]
-> [(Side, Vec2)]
-> [Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Side, Vec2)
-> (Side, Vec2) -> Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2
insertEdgeFragement [(Side, Vec2)]
vr ([(Side, Vec2)] -> [(Side, Vec2)]
forall a. HasCallStack => [a] -> [a]
tail ([(Side, Vec2)] -> [(Side, Vec2)]
forall a. HasCallStack => [a] -> [a]
cycle [(Side, Vec2)]
vr))
    in (Multwomap Vec2 Vec2
 -> (Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2)
 -> Multwomap Vec2 Vec2)
-> Multwomap Vec2 Vec2
-> [Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2]
-> Multwomap Vec2 Vec2
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Multwomap Vec2 Vec2
mmap Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2
f -> Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2
f Multwomap Vec2 Vec2
mmap) Multwomap Vec2 Vec2
forall k v. Multwomap k v
MM.empty [Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2]
inserts

constructResultPolygons :: Multwomap Vec2 Vec2 -> [Polygon]
constructResultPolygons :: Multwomap Vec2 Vec2 -> [Polygon]
constructResultPolygons Multwomap Vec2 Vec2
mmap = State (Multwomap Vec2 Vec2) [Polygon]
-> Multwomap Vec2 Vec2 -> [Polygon]
forall s a. State s a -> s -> a
evalState State (Multwomap Vec2 Vec2) [Polygon]
reconstructAllS Multwomap Vec2 Vec2
mmap

reconstructAllS :: State (Multwomap Vec2 Vec2) [Polygon]
reconstructAllS :: State (Multwomap Vec2 Vec2) [Polygon]
reconstructAllS = (Multwomap Vec2 Vec2 -> Maybe Vec2)
-> StateT (Multwomap Vec2 Vec2) Identity (Maybe Vec2)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Multwomap Vec2 Vec2 -> Maybe Vec2
forall k v. Multwomap k v -> Maybe k
MM.arbitraryKey StateT (Multwomap Vec2 Vec2) Identity (Maybe Vec2)
-> (Maybe Vec2 -> State (Multwomap Vec2 Vec2) [Polygon])
-> State (Multwomap Vec2 Vec2) [Polygon]
forall a b.
StateT (Multwomap Vec2 Vec2) Identity a
-> (a -> StateT (Multwomap Vec2 Vec2) Identity b)
-> StateT (Multwomap Vec2 Vec2) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Vec2
Nothing -> [Polygon] -> State (Multwomap Vec2 Vec2) [Polygon]
forall a. a -> StateT (Multwomap Vec2 Vec2) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just Vec2
start -> do
        Polygon
polygon <- Vec2 -> State (Multwomap Vec2 Vec2) Polygon
reconstructSingleS Vec2
start
        [Polygon]
rest <- State (Multwomap Vec2 Vec2) [Polygon]
reconstructAllS
        [Polygon] -> State (Multwomap Vec2 Vec2) [Polygon]
forall a. a -> StateT (Multwomap Vec2 Vec2) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Polygon
polygon Polygon -> [Polygon] -> [Polygon]
forall a. a -> [a] -> [a]
: [Polygon]
rest)

reconstructSingleS :: Vec2 -> State (Multwomap Vec2 Vec2) Polygon
reconstructSingleS :: Vec2 -> State (Multwomap Vec2 Vec2) Polygon
reconstructSingleS Vec2
start = (Multwomap Vec2 Vec2 -> Maybe (Vec2, Multwomap Vec2 Vec2))
-> StateT
     (Multwomap Vec2 Vec2) Identity (Maybe (Vec2, Multwomap Vec2 Vec2))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Vec2 -> Multwomap Vec2 Vec2 -> Maybe (Vec2, Multwomap Vec2 Vec2)
forall k v. Ord k => k -> Multwomap k v -> Maybe (v, Multwomap k v)
MM.extract Vec2
start) StateT
  (Multwomap Vec2 Vec2) Identity (Maybe (Vec2, Multwomap Vec2 Vec2))
-> (Maybe (Vec2, Multwomap Vec2 Vec2)
    -> State (Multwomap Vec2 Vec2) Polygon)
-> State (Multwomap Vec2 Vec2) Polygon
forall a b.
StateT (Multwomap Vec2 Vec2) Identity a
-> (a -> StateT (Multwomap Vec2 Vec2) Identity b)
-> StateT (Multwomap Vec2 Vec2) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Vec2, Multwomap Vec2 Vec2)
Nothing -> Polygon -> State (Multwomap Vec2 Vec2) Polygon
forall a. a -> StateT (Multwomap Vec2 Vec2) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Vec2] -> Polygon
Polygon [])
    Just (Vec2
next, Multwomap Vec2 Vec2
restEdgeFragments) -> do
        Multwomap Vec2 Vec2 -> StateT (Multwomap Vec2 Vec2) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Multwomap Vec2 Vec2
restEdgeFragments
        Polygon [Vec2]
rest <- Vec2 -> State (Multwomap Vec2 Vec2) Polygon
reconstructSingleS Vec2
next
        Polygon -> State (Multwomap Vec2 Vec2) Polygon
forall a. a -> StateT (Multwomap Vec2 Vec2) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Vec2] -> Polygon
Polygon (Vec2
start Vec2 -> [Vec2] -> [Vec2]
forall a. a -> [a] -> [a]
: [Vec2]
rest))

-- | The paper’s code on this is pretty unclear, if not misleading: it talks about
-- a »current polygon« and a »last result polygon«. By testing, it turns out those
-- two are the same, and one should simply look at one polygon, and not two
-- neighbours.
addTypes :: Operation -> PolygonOrientation -> IslandOrHole -> IslandOrHole -> [Polygon] -> [(Polygon, IslandOrHole)]
addTypes :: Operation
-> PolygonOrientation
-> IslandOrHole
-> IslandOrHole
-> [Polygon]
-> [(Polygon, IslandOrHole)]
addTypes Operation
op PolygonOrientation
orientationA IslandOrHole
polygonA_Type IslandOrHole
polygonB_Type = [Polygon] -> [(Polygon, IslandOrHole)]
go
  where
    go :: [Polygon] -> [(Polygon, IslandOrHole)]
go [] = []
    go (Polygon
currentPolygon:[Polygon]
rest) =
        let orientationsMatch :: Bool
orientationsMatch = Polygon -> PolygonOrientation
polygonOrientation Polygon
currentPolygon PolygonOrientation -> PolygonOrientation -> Bool
forall a. Eq a => a -> a -> Bool
== PolygonOrientation
orientationA
            orientationsShouldMatch :: Bool
orientationsShouldMatch = IslandOrHole -> IslandOrHole -> Operation -> RelativeOrientation
resultOrientation IslandOrHole
polygonA_Type IslandOrHole
polygonB_Type Operation
op RelativeOrientation -> RelativeOrientation -> Bool
forall a. Eq a => a -> a -> Bool
== RelativeOrientation
SameOrientation
            orient :: IslandOrHole -> IslandOrHole
orient
                | Bool
orientationsMatch Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
orientationsShouldMatch = IslandOrHole -> IslandOrHole
forall a. a -> a
id
                | Bool
otherwise = IslandOrHole -> IslandOrHole
flipHoleIsland
        in (Polygon
currentPolygon, IslandOrHole -> IslandOrHole
orient IslandOrHole
polygonA_Type) (Polygon, IslandOrHole)
-> [(Polygon, IslandOrHole)] -> [(Polygon, IslandOrHole)]
forall a. a -> [a] -> [a]
: [Polygon] -> [(Polygon, IslandOrHole)]
go [Polygon]
rest

    flipHoleIsland :: IslandOrHole -> IslandOrHole
flipHoleIsland IslandOrHole
Island = IslandOrHole
Hole
    flipHoleIsland IslandOrHole
Hole = IslandOrHole
Island

margalitKnott :: Operation -> Regularity -> (Polygon, IslandOrHole) -> (Polygon, IslandOrHole) -> [(Polygon, IslandOrHole)]
margalitKnott :: Operation
-> Regularity
-> (Polygon, IslandOrHole)
-> (Polygon, IslandOrHole)
-> [(Polygon, IslandOrHole)]
margalitKnott Operation
op Regularity
Regular (Polygon
polygonA, IslandOrHole
polygonA_Type) (Polygon
polygonB', IslandOrHole
polygonB_Type) =
    let polygonB :: Polygon
polygonB = Operation
-> Polygon -> Polygon -> IslandOrHole -> IslandOrHole -> Polygon
orientB Operation
op Polygon
polygonA Polygon
polygonB' IslandOrHole
polygonA_Type IslandOrHole
polygonB_Type

        vertexRingA :: CutPolygon
vertexRingA = Polygon -> Polygon -> CutPolygon
cutPolygon Polygon
polygonA Polygon
polygonB
        vertexRingB :: CutPolygon
vertexRingB = Polygon -> Polygon -> CutPolygon
cutPolygon Polygon
polygonB Polygon
polygonA

        (Side
ftA, Side
ftB) = IslandOrHole -> IslandOrHole -> Operation -> (Side, Side)
fragmentType IslandOrHole
polygonA_Type IslandOrHole
polygonB_Type Operation
op
        efA :: Multwomap Vec2 Vec2
efA = CutPolygon -> Side -> Polygon -> Multwomap Vec2 Vec2
buildEdgeFragementMap CutPolygon
vertexRingA Side
ftA Polygon
polygonB
        efB :: Multwomap Vec2 Vec2
efB = CutPolygon -> Side -> Polygon -> Multwomap Vec2 Vec2
buildEdgeFragementMap CutPolygon
vertexRingB Side
ftB Polygon
polygonA
        edgeFragments :: Multwomap Vec2 Vec2
edgeFragments = Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2 -> Multwomap Vec2 Vec2
forall k v.
Ord k =>
Multwomap k v -> Multwomap k v -> Multwomap k v
MM.union Multwomap Vec2 Vec2
efA Multwomap Vec2 Vec2
efB

        polygons :: [Polygon]
polygons = Multwomap Vec2 Vec2 -> [Polygon]
constructResultPolygons Multwomap Vec2 Vec2
edgeFragments

        polygonsTyped :: [(Polygon, IslandOrHole)]
polygonsTyped = Operation
-> PolygonOrientation
-> IslandOrHole
-> IslandOrHole
-> [Polygon]
-> [(Polygon, IslandOrHole)]
addTypes Operation
op (Polygon -> PolygonOrientation
polygonOrientation Polygon
polygonA) IslandOrHole
polygonA_Type IslandOrHole
polygonB_Type [Polygon]
polygons

        -- TODO: boundary edge fragment handling

    in [(Polygon, IslandOrHole)]
polygonsTyped

-- | Union of two polygons.
--
-- <<docs/haddock/Geometry/Algorithms/Clipping/MargalitKnott/union.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Algorithms/Clipping/MargalitKnott/union.svg" 150 150 $ \_ -> do
--     let p1 = boundingBoxPolygon [Vec2 10 10, Vec2 100 100]
--         p2 = boundingBoxPolygon [Vec2 50 50, Vec2 140 140]
--     for_ (unionPP p1 p2) $ \(polygon, _ty) -> cairoScope $ do
--         sketch polygon
--         setColor (mma 1 `withOpacity` 0.2)
--         fill
--     sketch (p1, p2) >> stroke
-- :}
-- Generated file: size 2KB, crc32: 0xcc4c9f5e
unionPP :: Polygon -> Polygon -> [(Polygon, IslandOrHole)]
unionPP :: Polygon -> Polygon -> [(Polygon, IslandOrHole)]
unionPP = Operation -> Polygon -> Polygon -> [(Polygon, IslandOrHole)]
ppBinop Operation
Union

-- | Intersection of two polygons.
--
-- The union will always be 'Island's, but for homogenity of types with
-- 'intersectionPP' etc. the type is included anyway.
--
-- <<docs/haddock/Geometry/Algorithms/Clipping/MargalitKnott/intersection.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Algorithms/Clipping/MargalitKnott/intersection.svg" 150 150 $ \_ -> do
--     let p1 = boundingBoxPolygon [Vec2 10 10, Vec2 100 100]
--         p2 = boundingBoxPolygon [Vec2 50 50, Vec2 140 140]
--     for_ (intersectionPP p1 p2) $ \(polygon, _ty) -> cairoScope $ do
--         sketch polygon
--         setColor (mma 1 `withOpacity` 0.2)
--         fill
--     sketch (p1, p2) >> stroke
-- :}
-- Generated file: size 2KB, crc32: 0xdaf13db5
intersectionPP :: Polygon -> Polygon -> [(Polygon, IslandOrHole)]
intersectionPP :: Polygon -> Polygon -> [(Polygon, IslandOrHole)]
intersectionPP = Operation -> Polygon -> Polygon -> [(Polygon, IslandOrHole)]
ppBinop Operation
Intersection

-- | Difference of two polygons: anything that is in the first argument, but not in the second.
--
-- <<docs/haddock/Geometry/Algorithms/Clipping/MargalitKnott/difference.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Algorithms/Clipping/MargalitKnott/difference.svg" 150 150 $ \_ -> do
--     let p1 = boundingBoxPolygon [Vec2 10 10, Vec2 100 100]
--         p2 = boundingBoxPolygon [Vec2 50 50, Vec2 140 140]
--     for_ (differencePP p1 p2) $ \(polygon, _ty) -> cairoScope $ do
--         sketch polygon
--         setColor (mma 1 `withOpacity` 0.2)
--         fill
--     sketch (p1, p2) >> stroke
-- :}
-- Generated file: size 2KB, crc32: 0x9388b325
differencePP
    :: Polygon -- ^ A
    -> Polygon -- ^ B
    -> [(Polygon, IslandOrHole)] -- ^ A-B
differencePP :: Polygon -> Polygon -> [(Polygon, IslandOrHole)]
differencePP = Operation -> Polygon -> Polygon -> [(Polygon, IslandOrHole)]
ppBinop Operation
Difference

-- | Anti-difference of two polygons: anything that is in the second argument, but
-- not in the first. Results are identical to @'flip' 'differencePP'@.
antiDifferencePP
    :: Polygon -- ^ A
    -> Polygon -- ^ B
    -> [(Polygon, IslandOrHole)] -- ^ B-A
antiDifferencePP :: Polygon -> Polygon -> [(Polygon, IslandOrHole)]
antiDifferencePP = Operation -> Polygon -> Polygon -> [(Polygon, IslandOrHole)]
ppBinop Operation
AntiDifference

ppBinop :: Operation -> Polygon -> Polygon -> [(Polygon, IslandOrHole)]
ppBinop :: Operation -> Polygon -> Polygon -> [(Polygon, IslandOrHole)]
ppBinop Operation
op Polygon
p1 Polygon
p2 = Operation
-> Regularity
-> (Polygon, IslandOrHole)
-> (Polygon, IslandOrHole)
-> [(Polygon, IslandOrHole)]
margalitKnott Operation
op Regularity
Regular (Polygon
p1, IslandOrHole
Island) (Polygon
p2, IslandOrHole
Island)