content: {-# 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 { rawShape :: Ptr TopoDS.Shape }
  
  acquireShape :: Shape -> Acquire (Ptr TopoDS.Shape)
  acquireShape (Shape ptr) = toAcquire ptr
  
  shapeFromAcquire :: Acquire (Ptr TopoDS.Shape) -> Shape
  shapeFromAcquire = Shape . unsafeFromAcquire
  
  toBoolean2D :: (Ptr TopoDS.Shape.Shape -> Ptr TopoDS.Shape.Shape -> Acquire (Ptr TopoDS.Shape.Shape)) -> Shape -> Shape -> Shape
  toBoolean2D f (Shape ptrA) (Shape ptrB) = Shape . unsafeFromAcquire $ do
      a <- toAcquire ptrA
      b <- toAcquire ptrB
      f a b
  
  -- | Take the union of two 2D shapes.
  -- The region occupied by either one of them
  union2D :: Shape -> Shape -> Shape
  union2D = toBoolean2D Fuse.fuse
  
  -- | Take the difference of two 2D shapes.
  -- The region occupied by the first, but not the second
  difference2D :: Shape -> Shape -> Shape
  difference2D = toBoolean2D Cut.cut
  
  -- | Take the intersection of two 2D shapes.
  -- The region occupied by both of them
  intersection2D :: Shape -> Shape -> Shape
  intersection2D = toBoolean2D Common.common
  
  toBooleans2D :: BOPAlgo.Operation.Operation -> [Shape] -> Shape
  toBooleans2D _ [] = emptyShape
  toBooleans2D _ [x] = x
  toBooleans2D op (h:shapes) = Shape . unsafeFromAcquire $ do
      firstPtr <- toAcquire . rawShape $ h
      ptrs <- traverse (toAcquire . rawShape) shapes
      bop <- BOPAlgo.BOP.new
      let builder = upcast bop
      liftIO $ do
          BOPAlgo.BOP.setOperation bop op
          BOPAlgo.Builder.addArgument builder firstPtr
          traverse_ (BOPAlgo.BOP.addTool bop) ptrs
          BOPAlgo.Builder.setRunParallel builder True
          BOPAlgo.Builder.perform builder
      BOPAlgo.Builder.shape builder
  
  -- | Take the union of a list of 2D shapes
  -- May be more performant than chaining multiple applications of `union2D`
  unions2D :: [Shape] -> Shape
  unions2D = toBooleans2D 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 = toBooleans2D BOPAlgo.Operation.Common
  
  -- | An empty 2D shape
  emptyShape :: Shape
  emptyShape = Shape . unsafeFromAcquire $ 
      upcast <$> (MakeFace.face =<< 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
      (<>) = union2D
  
  instance Monoid Shape where
      mempty = emptyShape
      mconcat = unions2D
  
  instance Lattice Shape where 
      (/\) = intersection2D
      (\/) = union2D
  
  instance BoundedJoinSemiLattice Shape where
      bottom = emptyShape