module Waterfall.TwoD.Shape
( Shape
, makeShape
, shapePaths
, unitCircle
, unitSquare
, centeredSquare
, unitPolygon
) where

import Waterfall.TwoD.Internal.Shape (Shape (..))
import Waterfall.TwoD.Internal.Path2D (Path2D (..))
import Waterfall.TwoD.Transforms (translate2D, rotate2D)
import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)
import Waterfall.Internal.Edges (allWires)
import qualified OpenCascade.BRepBuilderAPI.MakeFace as MakeFace
import OpenCascade.Inheritance (upcast)
import Linear (unit, _x, _y, zero, V2 (..))
import Waterfall.Path.Common (pathFrom, arcViaTo, lineTo, line)
import Waterfall.Internal.Path.Common (RawPath(ComplexRawPath))

-- | Construct a 2D Shape from a closed path 
makeShape :: Path2D -> Shape
makeShape :: Path2D -> Shape
makeShape (Path2D (ComplexRawPath Ptr Wire
r)) = Ptr Shape -> Shape
Shape (Ptr Shape -> Shape)
-> (Acquire (Ptr Shape) -> Ptr Shape)
-> Acquire (Ptr Shape)
-> Shape
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acquire (Ptr Shape) -> Ptr Shape
forall a. Acquire a -> a
unsafeFromAcquire  (Acquire (Ptr Shape) -> Shape) -> Acquire (Ptr Shape) -> Shape
forall a b. (a -> b) -> a -> b
$ do
    Ptr Wire
p <- Ptr Wire -> Acquire (Ptr Wire)
forall a. a -> Acquire a
toAcquire Ptr Wire
r
    Ptr Face -> Ptr Shape
forall a b. SubTypeOf a b => Ptr b -> Ptr a
upcast (Ptr Face -> Ptr Shape)
-> Acquire (Ptr Face) -> Acquire (Ptr Shape)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr MakeFace -> Acquire (Ptr Face)
MakeFace.face (Ptr MakeFace -> Acquire (Ptr Face))
-> Acquire (Ptr MakeFace) -> Acquire (Ptr Face)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Wire -> Bool -> Acquire (Ptr MakeFace)
MakeFace.fromWire Ptr Wire
p Bool
False)
makeShape Path2D
_ = Ptr Shape -> Shape
Shape (Ptr Shape -> Shape)
-> (Acquire (Ptr Shape) -> Ptr Shape)
-> Acquire (Ptr Shape)
-> Shape
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acquire (Ptr Shape) -> Ptr Shape
forall a. Acquire a -> a
unsafeFromAcquire (Acquire (Ptr Shape) -> Shape) -> Acquire (Ptr Shape) -> Shape
forall a b. (a -> b) -> a -> b
$
    Ptr Face -> Ptr Shape
forall a b. SubTypeOf a b => Ptr b -> Ptr a
upcast (Ptr Face -> Ptr Shape)
-> Acquire (Ptr Face) -> Acquire (Ptr Shape)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr MakeFace -> Acquire (Ptr Face)
MakeFace.face (Ptr MakeFace -> Acquire (Ptr Face))
-> Acquire (Ptr MakeFace) -> Acquire (Ptr Face)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Acquire (Ptr MakeFace)
MakeFace.new)

-- | Get the paths back from a 2D shape
-- 
-- Ideally:
--
-- @
-- shapePaths . fromPath ≡ pure
-- @
shapePaths :: Shape -> [Path2D] 
shapePaths :: Shape -> [Path2D]
shapePaths (Shape Ptr Shape
r) = (Ptr Wire -> Path2D) -> [Ptr Wire] -> [Path2D]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RawPath -> Path2D
Path2D (RawPath -> Path2D) -> (Ptr Wire -> RawPath) -> Ptr Wire -> Path2D
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Wire -> RawPath
ComplexRawPath) ([Ptr Wire] -> [Path2D])
-> (Acquire [Ptr Wire] -> [Ptr Wire])
-> Acquire [Ptr Wire]
-> [Path2D]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acquire [Ptr Wire] -> [Ptr Wire]
forall a. Acquire a -> a
unsafeFromAcquire (Acquire [Ptr Wire] -> [Path2D]) -> Acquire [Ptr Wire] -> [Path2D]
forall a b. (a -> b) -> a -> b
$ do
    Ptr Shape
s <- Ptr Shape -> Acquire (Ptr Shape)
forall a. a -> Acquire a
toAcquire Ptr Shape
r 
    Ptr Shape -> Acquire [Ptr Wire]
allWires Ptr Shape
s 

-- | Circle with radius 1, centered on the origin
unitCircle :: Shape
unitCircle :: Shape
unitCircle = Path2D -> Shape
makeShape (Path2D -> Shape) -> Path2D -> Shape
forall a b. (a -> b) -> a -> b
$ V2 Double -> [V2 Double -> (V2 Double, Path2D)] -> Path2D
forall path point.
Monoid path =>
point -> [point -> (point, path)] -> path
pathFrom (ASetter' (V2 Double) Double -> V2 Double
forall (t :: * -> *) a.
(Additive t, Num a) =>
ASetter' (t a) a -> t a
unit ASetter' (V2 Double) Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x)
                [ V2 Double -> V2 Double -> V2 Double -> (V2 Double, Path2D)
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> point -> (point, path)
arcViaTo (ASetter' (V2 Double) Double -> V2 Double
forall (t :: * -> *) a.
(Additive t, Num a) =>
ASetter' (t a) a -> t a
unit ASetter' (V2 Double) Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) (V2 Double -> V2 Double
forall a. Num a => a -> a
negate (V2 Double -> V2 Double) -> V2 Double -> V2 Double
forall a b. (a -> b) -> a -> b
$ ASetter' (V2 Double) Double -> V2 Double
forall (t :: * -> *) a.
(Additive t, Num a) =>
ASetter' (t a) a -> t a
unit ASetter' (V2 Double) Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x)
                , V2 Double -> V2 Double -> V2 Double -> (V2 Double, Path2D)
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> point -> (point, path)
arcViaTo (V2 Double -> V2 Double
forall a. Num a => a -> a
negate (V2 Double -> V2 Double) -> V2 Double -> V2 Double
forall a b. (a -> b) -> a -> b
$ ASetter' (V2 Double) Double -> V2 Double
forall (t :: * -> *) a.
(Additive t, Num a) =>
ASetter' (t a) a -> t a
unit ASetter' (V2 Double) Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) (ASetter' (V2 Double) Double -> V2 Double
forall (t :: * -> *) a.
(Additive t, Num a) =>
ASetter' (t a) a -> t a
unit ASetter' (V2 Double) Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x)
                ]

-- | Square with side length of 1, one vertex on the origin, another on \( (1, 1) \)
unitSquare :: Shape
unitSquare :: Shape
unitSquare =
    Path2D -> Shape
makeShape (Path2D -> Shape) -> Path2D -> Shape
forall a b. (a -> b) -> a -> b
$ V2 Double -> [V2 Double -> (V2 Double, Path2D)] -> Path2D
forall path point.
Monoid path =>
point -> [point -> (point, path)] -> path
pathFrom V2 Double
forall a. Num a => V2 a
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
        [ V2 Double -> V2 Double -> (V2 Double, Path2D)
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> (point, path)
lineTo (ASetter' (V2 Double) Double -> V2 Double
forall (t :: * -> *) a.
(Additive t, Num a) =>
ASetter' (t a) a -> t a
unit ASetter' (V2 Double) Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x)
        , V2 Double -> V2 Double -> (V2 Double, Path2D)
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> (point, path)
lineTo (Double -> Double -> V2 Double
forall a. a -> a -> V2 a
V2 Double
1 Double
1)
        , V2 Double -> V2 Double -> (V2 Double, Path2D)
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> (point, path)
lineTo (ASetter' (V2 Double) Double -> V2 Double
forall (t :: * -> *) a.
(Additive t, Num a) =>
ASetter' (t a) a -> t a
unit ASetter' (V2 Double) Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y)
        , V2 Double -> V2 Double -> (V2 Double, Path2D)
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> (point, path)
lineTo V2 Double
forall a. Num a => V2 a
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
        ]

-- | Square with side length of 1, centered on the origin
centeredSquare :: Shape
centeredSquare :: Shape
centeredSquare = V2 Double -> Shape -> Shape
forall a. Transformable2D a => V2 Double -> a -> a
translate2D (Double -> Double -> V2 Double
forall a. a -> a -> V2 a
V2 (-Double
0.5) (-Double
0.5)) Shape
unitSquare

-- | \(n\) sided Polygon, centered on the origin
-- 
-- Ill-defined when n <= 2
unitPolygon :: Integer -> Shape
unitPolygon :: Integer -> Shape
unitPolygon Integer
n = 
    let n' :: Double
n' = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n
        points :: [V2 Double]
points = [
            Double -> V2 Double -> V2 Double
forall a. Transformable2D a => Double -> a -> a
rotate2D (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
n') (ASetter' (V2 Double) Double -> V2 Double
forall (t :: * -> *) a.
(Additive t, Num a) =>
ASetter' (t a) a -> t a
unit ASetter' (V2 Double) Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x)
            | Integer
i <- [Integer
0..Integer
n]
            ]
        paths :: Path2D
paths = [Path2D] -> Path2D
forall a. Monoid a => [a] -> a
mconcat [
            V2 Double -> V2 Double -> Path2D
forall point path.
(AnyPath point path, Epsilon point) =>
point -> point -> path
line V2 Double
a V2 Double
b
            | (V2 Double
a, V2 Double
b) <- [V2 Double] -> [V2 Double] -> [(V2 Double, V2 Double)]
forall a b. [a] -> [b] -> [(a, b)]
zip [V2 Double]
points ([V2 Double] -> [V2 Double]
forall a. HasCallStack => [a] -> [a]
tail [V2 Double]
points)
            ]
        in Path2D -> Shape
makeShape Path2D
paths