module Geometry.Algorithms.Clipping.SutherlandHodgman (sutherlandHodgman) where



import Geometry.Core


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

-- | Clip a polygon with a convex clipping mask using the
-- [Sutherland-Hodgman](https://en.wikipedia.org/wiki/Sutherland%E2%80%93Hodgman_algorithm)
-- algorithm.
--
-- __Note:__ The precondition (convexity) is not checked!
--
-- <<docs/haddock/Geometry/Algorithms/Clipping/SutherlandHodgman/sutherland_hodgman.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Algorithms/Clipping/SutherlandHodgman/sutherland_hodgman.svg" 110 100 $ \_ -> do
--     let subject = Polygon [Vec2 10 10, Vec2 10 90, Vec2 50 50, Vec2 90 90, Vec2 90 10]
--         Polygon scissors' = boundingBoxPolygon [Vec2 40 30, Vec2 100 80]
--         scissors = Polygon ( scissors')
--         clipped = sutherlandHodgman subject scissors
--     sketch clipped >> setColor (mma 0 `withOpacity` 0.5) >> fill
--     sketch subject >> setColor (mma 1) >> stroke
--     sketch scissors >> setColor (mma 3) >> setDash [3,3] 0 >> stroke
-- :}
-- Generated file: size 2KB, crc32: 0x722cb97a
sutherlandHodgman
    :: Polygon -- ^ Subject
    -> Polygon -- ^ __Convex__ scissors
    -> Polygon
sutherlandHodgman :: Polygon -> Polygon -> Polygon
sutherlandHodgman Polygon
subject Polygon
scissors = (Polygon -> Line -> Polygon) -> Polygon -> [Line] -> Polygon
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (PolygonOrientation -> Polygon -> Line -> Polygon
cutOffEdge (Polygon -> PolygonOrientation
polygonOrientation Polygon
scissors)) Polygon
subject (Polygon -> [Line]
polygonEdges Polygon
scissors)

cutOffEdge :: PolygonOrientation -> Polygon -> Line -> Polygon
cutOffEdge :: PolygonOrientation -> Polygon -> Line -> Polygon
cutOffEdge PolygonOrientation
o (Polygon [Vec2]
corners) Line
clipEdge = [Vec2] -> Polygon
Polygon ([Vec2] -> Polygon) -> ([[Vec2]] -> [Vec2]) -> [[Vec2]] -> Polygon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Vec2]] -> [Vec2]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Vec2]] -> Polygon) -> [[Vec2]] -> Polygon
forall a b. (a -> b) -> a -> b
$ (Vec2 -> Vec2 -> [Vec2]) -> [Vec2] -> [Vec2] -> [[Vec2]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
    (\Vec2
p1 Vec2
p2 ->
        let intersectingPoint :: Vec2
intersectingPoint = Line -> Line -> Vec2
intersectInfiniteLines (Vec2 -> Vec2 -> Line
Line Vec2
p1 Vec2
p2) Line
clipEdge
        in if PolygonOrientation -> Vec2 -> Line -> Bool
inside PolygonOrientation
o Vec2
p2 Line
clipEdge
            then if PolygonOrientation -> Vec2 -> Line -> Bool
outside PolygonOrientation
o Vec2
p1 Line
clipEdge
                then [Vec2
intersectingPoint, Vec2
p2]
                else [Vec2
p2]
            else if PolygonOrientation -> Vec2 -> Line -> Bool
inside PolygonOrientation
o Vec2
p1 Line
clipEdge
                then [Vec2
intersectingPoint]
                else []
        )
    [Vec2]
corners
    ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
tail ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
cycle [Vec2]
corners))

inside :: PolygonOrientation -> Vec2 -> Line -> Bool
inside :: PolygonOrientation -> Vec2 -> Line -> Bool
inside PolygonOrientation
o Vec2
p (Line Vec2
a Vec2
b) = Vec2 -> Vec2 -> Double
cross (Vec2
a Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
p) (Vec2
b Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
p) Double -> Double -> Bool
`f` Double
0
  where
    f :: Double -> Double -> Bool
f = case PolygonOrientation
o of
        PolygonOrientation
PolygonPositive -> Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
(>) -- Sign determined by testing :-E
        PolygonOrientation
PolygonNegative -> Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
(<)

outside :: PolygonOrientation -> Vec2 -> Line -> Bool
outside :: PolygonOrientation -> Vec2 -> Line -> Bool
outside PolygonOrientation
o Vec2
p = Bool -> Bool
not (Bool -> Bool) -> (Line -> Bool) -> Line -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolygonOrientation -> Vec2 -> Line -> Bool
inside PolygonOrientation
o Vec2
p