{-# OPTIONS_HADDOCK not-home #-}
module Waterfall.TwoD.Internal.Shape
( Shape (..)
, acquireShape
, shapeFromAcquire
, union2D
, difference2D
, intersection2D
, unions2D
, intersections2D
, emptyShape
) where

import qualified OpenCascade.TopoDS as TopoDS
import Foreign.Ptr
import Data.Acquire (Acquire)
import Algebra.Lattice
import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)
import qualified OpenCascade.BRepAlgoAPI.Fuse as Fuse
import qualified OpenCascade.BRepAlgoAPI.Cut as Cut
import qualified OpenCascade.BRepAlgoAPI.Common as Common
import qualified OpenCascade.TopoDS.Shape as TopoDS.Shape
import qualified OpenCascade.BRepBuilderAPI.MakeFace as MakeFace
import qualified OpenCascade.BOPAlgo.Operation as BOPAlgo.Operation
import qualified OpenCascade.BOPAlgo.BOP as BOPAlgo.BOP
import qualified OpenCascade.BOPAlgo.Builder as BOPAlgo.Builder
import OpenCascade.Inheritance (upcast)
import Control.Monad.IO.Class (liftIO)
import Data.Foldable (traverse_)

-- | A Region in 2D Space 
-- 
-- In general, this is used as a face, and extruded along some sort of path
--
-- Under the hood, this is represented by an OpenCascade `TopoDS.Shape`
-- 
-- This should be of type `TopoDS.Face`, constrained to the plane \( z=0 \).
--
-- Please feel free to report a bug if you're able to construct a `Shape`
-- which does not lie on this plane (without using Internal functions).
-- Or which is not either a `TopoDS.Face`, or a composite of faces.
newtype Shape = Shape { Shape -> Ptr Shape
rawShape :: Ptr TopoDS.Shape }

acquireShape :: Shape -> Acquire (Ptr TopoDS.Shape)
acquireShape :: Shape -> Acquire (Ptr Shape)
acquireShape (Shape Ptr Shape
ptr) = Ptr Shape -> Acquire (Ptr Shape)
forall a. a -> Acquire a
toAcquire Ptr Shape
ptr

shapeFromAcquire :: Acquire (Ptr TopoDS.Shape) -> Shape
shapeFromAcquire :: Acquire (Ptr Shape) -> Shape
shapeFromAcquire = 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

toBoolean2D :: (Ptr TopoDS.Shape.Shape -> Ptr TopoDS.Shape.Shape -> Acquire (Ptr TopoDS.Shape.Shape)) -> Shape -> Shape -> Shape
toBoolean2D :: (Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape))
-> Shape -> Shape -> Shape
toBoolean2D Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape)
f (Shape Ptr Shape
ptrA) (Shape Ptr Shape
ptrB) = 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 Shape
a <- Ptr Shape -> Acquire (Ptr Shape)
forall a. a -> Acquire a
toAcquire Ptr Shape
ptrA
    Ptr Shape
b <- Ptr Shape -> Acquire (Ptr Shape)
forall a. a -> Acquire a
toAcquire Ptr Shape
ptrB
    Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape)
f Ptr Shape
a Ptr Shape
b

-- | Take the union of two 2D shapes.
-- The region occupied by either one of them
union2D :: Shape -> Shape -> Shape
union2D :: Shape -> Shape -> Shape
union2D = (Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape))
-> Shape -> Shape -> Shape
toBoolean2D Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape)
Fuse.fuse

-- | Take the difference of two 2D shapes.
-- The region occupied by the first, but not the second
difference2D :: Shape -> Shape -> Shape
difference2D :: Shape -> Shape -> Shape
difference2D = (Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape))
-> Shape -> Shape -> Shape
toBoolean2D Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape)
Cut.cut

-- | Take the intersection of two 2D shapes.
-- The region occupied by both of them
intersection2D :: Shape -> Shape -> Shape
intersection2D :: Shape -> Shape -> Shape
intersection2D = (Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape))
-> Shape -> Shape -> Shape
toBoolean2D Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape)
Common.common

toBooleans2D :: BOPAlgo.Operation.Operation -> [Shape] -> Shape
toBooleans2D :: Operation -> [Shape] -> Shape
toBooleans2D Operation
_ [] = Shape
emptyShape
toBooleans2D Operation
_ [Shape
x] = Shape
x
toBooleans2D Operation
op (Shape
h:[Shape]
shapes) = 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 Shape
firstPtr <- Ptr Shape -> Acquire (Ptr Shape)
forall a. a -> Acquire a
toAcquire (Ptr Shape -> Acquire (Ptr Shape))
-> (Shape -> Ptr Shape) -> Shape -> Acquire (Ptr Shape)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Shape -> Ptr Shape
rawShape (Shape -> Acquire (Ptr Shape)) -> Shape -> Acquire (Ptr Shape)
forall a b. (a -> b) -> a -> b
$ Shape
h
    [Ptr Shape]
ptrs <- (Shape -> Acquire (Ptr Shape)) -> [Shape] -> Acquire [Ptr Shape]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Ptr Shape -> Acquire (Ptr Shape)
forall a. a -> Acquire a
toAcquire (Ptr Shape -> Acquire (Ptr Shape))
-> (Shape -> Ptr Shape) -> Shape -> Acquire (Ptr Shape)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Shape -> Ptr Shape
rawShape) [Shape]
shapes
    Ptr BOP
bop <- Acquire (Ptr BOP)
BOPAlgo.BOP.new
    let builder :: Ptr Builder
builder = Ptr BOP -> Ptr Builder
forall a b. SubTypeOf a b => Ptr b -> Ptr a
upcast Ptr BOP
bop
    IO () -> Acquire ()
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Acquire ()) -> IO () -> Acquire ()
forall a b. (a -> b) -> a -> b
$ do
        Ptr BOP -> Operation -> IO ()
BOPAlgo.BOP.setOperation Ptr BOP
bop Operation
op
        Ptr Builder -> Ptr Shape -> IO ()
BOPAlgo.Builder.addArgument Ptr Builder
builder Ptr Shape
firstPtr
        (Ptr Shape -> IO ()) -> [Ptr Shape] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Ptr BOP -> Ptr Shape -> IO ()
BOPAlgo.BOP.addTool Ptr BOP
bop) [Ptr Shape]
ptrs
        Ptr Builder -> Bool -> IO ()
BOPAlgo.Builder.setRunParallel Ptr Builder
builder Bool
True
        Ptr Builder -> IO ()
BOPAlgo.Builder.perform Ptr Builder
builder
    Ptr Builder -> Acquire (Ptr Shape)
BOPAlgo.Builder.shape Ptr Builder
builder

-- | Take the union of a list of 2D shapes
-- May be more performant than chaining multiple applications of `union2D`
unions2D :: [Shape] -> Shape
unions2D :: [Shape] -> Shape
unions2D = Operation -> [Shape] -> Shape
toBooleans2D Operation
BOPAlgo.Operation.Fuse

-- | Take the intersection of a list of 2D shapes
-- May be more performant than chaining multiple applications of `intersection2D`
intersections2D :: [Shape] -> Shape
intersections2D :: [Shape] -> Shape
intersections2D = Operation -> [Shape] -> Shape
toBooleans2D Operation
BOPAlgo.Operation.Common

-- | An empty 2D shape
emptyShape :: Shape
emptyShape :: Shape
emptyShape = 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)

-- defining these boolean operators here, rather than in Waterfall.TwoD.Booleans 
-- means that we can use them in typeclass instances without resorting to orphans

instance Semigroup Shape where
    <> :: Shape -> Shape -> Shape
(<>) = Shape -> Shape -> Shape
union2D

instance Monoid Shape where
    mempty :: Shape
mempty = Shape
emptyShape
    mconcat :: [Shape] -> Shape
mconcat = [Shape] -> Shape
unions2D

instance Lattice Shape where 
    /\ :: Shape -> Shape -> Shape
(/\) = Shape -> Shape -> Shape
intersection2D
    \/ :: Shape -> Shape -> Shape
(\/) = Shape -> Shape -> Shape
union2D

instance BoundedJoinSemiLattice Shape where
    bottom :: Shape
bottom = Shape
emptyShape