{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE InstanceSigs #-}
module Waterfall.Internal.Solid 
( Solid (..)
, acquireSolid
, solidFromAcquire
, union
, difference
, intersection
, unions
, intersections
, nowhere
, complement
, debug
) where

import Data.Acquire
import Foreign.Ptr
import Algebra.Lattice
import Control.Monad.IO.Class (liftIO)
import qualified OpenCascade.TopoDS as TopoDS
import qualified OpenCascade.TopoDS.Shape as TopoDS.Shape
import qualified OpenCascade.BRepAlgoAPI.Fuse as Fuse
import qualified OpenCascade.BRepAlgoAPI.Cut as Cut
import qualified OpenCascade.BRepAlgoAPI.Common as Common
import qualified OpenCascade.BRepBuilderAPI.MakeSolid as MakeSolid
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 Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)
import qualified OpenCascade.BOPAlgo.Builder as BOPAlgo
import Data.Foldable (traverse_)

-- | The Boundary Representation of a solid object.
--
-- Alternatively, a region of 3d Space.
--
-- Under the hood, this is represented by an OpenCascade `TopoDS.Shape`.
-- The underlying shape should either be a Solid, or a CompSolid.
-- 
-- While you shouldn't need to know what this means to use the library,
-- please feel free to report a bug if you're able to construct a `Solid`
-- where this isnt' the case (without using internal functions).
newtype Solid = Solid { Solid -> Ptr Shape
rawSolid :: Ptr TopoDS.Shape.Shape }

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

solidFromAcquire :: Acquire (Ptr TopoDS.Shape.Shape) -> Solid
solidFromAcquire :: Acquire (Ptr Shape) -> Solid
solidFromAcquire = Ptr Shape -> Solid
Solid (Ptr Shape -> Solid)
-> (Acquire (Ptr Shape) -> Ptr Shape)
-> Acquire (Ptr Shape)
-> Solid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acquire (Ptr Shape) -> Ptr Shape
forall a. Acquire a -> a
unsafeFromAcquire


-- | print debug information about a Solid when it's evaluated 
-- exposes the properties of the underlying OpenCacade.TopoDS.Shape
debug :: Solid -> String
debug :: Solid -> String
debug (Solid Ptr Shape
ptr) = 
    let 
        fshow :: Show a => IO a -> IO String 
        fshow :: forall a. Show a => IO a -> IO String
fshow = (a -> String) -> IO a -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> String
forall a. Show a => a -> String
show
        actions :: [(String, Ptr Shape -> IO String)]
actions = 
            [ (String
"type", IO ShapeEnum -> IO String
forall a. Show a => IO a -> IO String
fshow (IO ShapeEnum -> IO String)
-> (Ptr Shape -> IO ShapeEnum) -> Ptr Shape -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO ShapeEnum
TopoDS.Shape.shapeType)
            , (String
"closed", IO Bool -> IO String
forall a. Show a => IO a -> IO String
fshow (IO Bool -> IO String)
-> (Ptr Shape -> IO Bool) -> Ptr Shape -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO Bool
TopoDS.Shape.closed)
            , (String
"infinite", IO Bool -> IO String
forall a. Show a => IO a -> IO String
fshow (IO Bool -> IO String)
-> (Ptr Shape -> IO Bool) -> Ptr Shape -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO Bool
TopoDS.Shape.infinite)
            , (String
"orientable", IO Bool -> IO String
forall a. Show a => IO a -> IO String
fshow (IO Bool -> IO String)
-> (Ptr Shape -> IO Bool) -> Ptr Shape -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO Bool
TopoDS.Shape.orientable)
            , (String
"orientation", IO Orientation -> IO String
forall a. Show a => IO a -> IO String
fshow (IO Orientation -> IO String)
-> (Ptr Shape -> IO Orientation) -> Ptr Shape -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO Orientation
TopoDS.Shape.orientation)
            , (String
"null", IO Bool -> IO String
forall a. Show a => IO a -> IO String
fshow (IO Bool -> IO String)
-> (Ptr Shape -> IO Bool) -> Ptr Shape -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO Bool
TopoDS.Shape.isNull)
            , (String
"free", IO Bool -> IO String
forall a. Show a => IO a -> IO String
fshow (IO Bool -> IO String)
-> (Ptr Shape -> IO Bool) -> Ptr Shape -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO Bool
TopoDS.Shape.free)
            , (String
"locked", IO Bool -> IO String
forall a. Show a => IO a -> IO String
fshow (IO Bool -> IO String)
-> (Ptr Shape -> IO Bool) -> Ptr Shape -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO Bool
TopoDS.Shape.locked)
            , (String
"modified", IO Bool -> IO String
forall a. Show a => IO a -> IO String
fshow (IO Bool -> IO String)
-> (Ptr Shape -> IO Bool) -> Ptr Shape -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO Bool
TopoDS.Shape.modified)
            , (String
"checked",  IO Bool -> IO String
forall a. Show a => IO a -> IO String
fshow (IO Bool -> IO String)
-> (Ptr Shape -> IO Bool) -> Ptr Shape -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO Bool
TopoDS.Shape.checked)
            , (String
"convex", IO Bool -> IO String
forall a. Show a => IO a -> IO String
fshow (IO Bool -> IO String)
-> (Ptr Shape -> IO Bool) -> Ptr Shape -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO Bool
TopoDS.Shape.convex)
            , (String
"nbChildren", IO Int -> IO String
forall a. Show a => IO a -> IO String
fshow (IO Int -> IO String)
-> (Ptr Shape -> IO Int) -> Ptr Shape -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO Int
TopoDS.Shape.nbChildren)
            ]
    in Acquire String -> String
forall a. Acquire a -> a
unsafeFromAcquire (Acquire String -> String) -> Acquire String -> String
forall a b. (a -> b) -> a -> b
$ do
        Ptr Shape
s <- Ptr Shape -> Acquire (Ptr Shape)
forall a. a -> Acquire a
toAcquire Ptr Shape
ptr
        IO String -> Acquire String
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> Acquire String) -> IO String -> Acquire String
forall a b. (a -> b) -> a -> b
$ (((String, Ptr Shape -> IO String) -> IO String)
-> [(String, Ptr Shape -> IO String)] -> IO String
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
`foldMap` [(String, Ptr Shape -> IO String)]
actions) (((String, Ptr Shape -> IO String) -> IO String) -> IO String)
-> ((String, Ptr Shape -> IO String) -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \(String
actionName, Ptr Shape -> IO String
value) -> 
                (String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"\t" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
actionName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\t\t") IO String -> IO String -> IO String
forall a. Semigroup a => a -> a -> a
<> Ptr Shape -> IO String
value Ptr Shape
s IO String -> IO String -> IO String
forall a. Semigroup a => a -> a -> a
<> (String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"\n")

{--
-- TODO: this does not work, need to fix
everywhere :: Solid
everywhere = complement $ nowhere
--}

-- | Invert a Solid, equivalent to `not` in boolean algebra.
--
-- The complement of a solid represents the solid with the same surface,
-- but where the opposite side of that surface is the \"inside\" of the solid.
--
-- Be warned that @complement nowhere@ does not appear to work correctly.
complement :: Solid -> Solid
complement :: Solid -> Solid
complement (Solid Ptr Shape
ptr) = Ptr Shape -> Solid
Solid (Ptr Shape -> Solid)
-> (Acquire (Ptr Shape) -> Ptr Shape)
-> Acquire (Ptr Shape)
-> Solid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acquire (Ptr Shape) -> Ptr Shape
forall a. Acquire a -> a
unsafeFromAcquire (Acquire (Ptr Shape) -> Solid) -> Acquire (Ptr Shape) -> Solid
forall a b. (a -> b) -> a -> b
$ Ptr Shape -> Acquire (Ptr Shape)
TopoDS.Shape.complemented (Ptr Shape -> Acquire (Ptr Shape))
-> Acquire (Ptr Shape) -> Acquire (Ptr Shape)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Shape -> Acquire (Ptr Shape)
forall a. a -> Acquire a
toAcquire Ptr Shape
ptr

-- | An empty solid
--
-- Be warned that @complement nowhere@ does not appear to work correctly.
nowhere :: Solid 
nowhere :: Solid
nowhere =  Ptr Shape -> Solid
Solid (Ptr Shape -> Solid)
-> (Acquire (Ptr Shape) -> Ptr Shape)
-> Acquire (Ptr Shape)
-> Solid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acquire (Ptr Shape) -> Ptr Shape
forall a. Acquire a -> a
unsafeFromAcquire (Acquire (Ptr Shape) -> Solid) -> Acquire (Ptr Shape) -> Solid
forall a b. (a -> b) -> a -> b
$ Ptr Solid -> Ptr Shape
forall a b. SubTypeOf a b => Ptr b -> Ptr a
upcast (Ptr Solid -> Ptr Shape)
-> Acquire (Ptr Solid) -> Acquire (Ptr Shape)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr MakeSolid -> Acquire (Ptr Solid)
MakeSolid.solid (Ptr MakeSolid -> Acquire (Ptr Solid))
-> Acquire (Ptr MakeSolid) -> Acquire (Ptr Solid)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Acquire (Ptr MakeSolid)
MakeSolid.new)

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

toBoolean :: (Ptr TopoDS.Shape -> Ptr TopoDS.Shape -> Acquire (Ptr TopoDS.Shape)) -> Solid -> Solid -> Solid
toBoolean :: (Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape))
-> Solid -> Solid -> Solid
toBoolean Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape)
f (Solid Ptr Shape
ptrA) (Solid Ptr Shape
ptrB) = Ptr Shape -> Solid
Solid (Ptr Shape -> Solid)
-> (Acquire (Ptr Shape) -> Ptr Shape)
-> Acquire (Ptr Shape)
-> Solid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acquire (Ptr Shape) -> Ptr Shape
forall a. Acquire a -> a
unsafeFromAcquire (Acquire (Ptr Shape) -> Solid) -> Acquire (Ptr Shape) -> Solid
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 sum of two solids
--
-- The region occupied by either one of them.
union :: Solid -> Solid -> Solid
union :: Solid -> Solid -> Solid
union = (Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape))
-> Solid -> Solid -> Solid
toBoolean Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape)
Fuse.fuse


toBooleans :: BOPAlgo.Operation.Operation -> [Solid] -> Solid
toBooleans :: Operation -> [Solid] -> Solid
toBooleans Operation
_ [] = Solid
nowhere
toBooleans Operation
_ [Solid
x] = Solid
x
toBooleans Operation
op (Solid
h:[Solid]
solids) = Ptr Shape -> Solid
Solid (Ptr Shape -> Solid)
-> (Acquire (Ptr Shape) -> Ptr Shape)
-> Acquire (Ptr Shape)
-> Solid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acquire (Ptr Shape) -> Ptr Shape
forall a. Acquire a -> a
unsafeFromAcquire (Acquire (Ptr Shape) -> Solid) -> Acquire (Ptr Shape) -> Solid
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))
-> (Solid -> Ptr Shape) -> Solid -> Acquire (Ptr Shape)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Solid -> Ptr Shape
rawSolid (Solid -> Acquire (Ptr Shape)) -> Solid -> Acquire (Ptr Shape)
forall a b. (a -> b) -> a -> b
$ Solid
h
    [Ptr Shape]
ptrs <- (Solid -> Acquire (Ptr Shape)) -> [Solid] -> 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))
-> (Solid -> Ptr Shape) -> Solid -> Acquire (Ptr Shape)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Solid -> Ptr Shape
rawSolid) [Solid]
solids
    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.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 sum of a list of solids 
-- 
-- May be more performant than chaining multiple applications of `union`
unions :: [Solid] -> Solid
unions :: [Solid] -> Solid
unions = Operation -> [Solid] -> Solid
toBooleans Operation
BOPAlgo.Operation.Fuse

-- | Take the difference of two solids
-- 
-- The region occupied by the first, but not the second.
difference :: Solid -> Solid -> Solid
difference :: Solid -> Solid -> Solid
difference = (Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape))
-> Solid -> Solid -> Solid
toBoolean Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape)
Cut.cut

-- | Take the intersection of two solids 
--
-- The region occupied by both of them.
intersection :: Solid -> Solid -> Solid
intersection :: Solid -> Solid -> Solid
intersection = (Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape))
-> Solid -> Solid -> Solid
toBoolean Ptr Shape -> Ptr Shape -> Acquire (Ptr Shape)
Common.common


-- | Take the intersection of a list of solids 
-- 
-- May be more performant than chaining multiple applications of `intersection`
intersections :: [Solid] -> Solid
intersections :: [Solid] -> Solid
intersections = Operation -> [Solid] -> Solid
toBooleans Operation
BOPAlgo.Operation.Common

-- | While `Solid` could form a Semigroup via either `union` or `intersection`.
-- the default Semigroup is from `union`.
--
-- The Semigroup from `intersection` can be obtained using `Meet` from the lattices package.
instance Semigroup Solid where
    (<>) :: Solid -> Solid -> Solid
    <> :: Solid -> Solid -> Solid
(<>) = Solid -> Solid -> Solid
union

instance Monoid Solid where
    mempty :: Solid
mempty = Solid
nowhere
    mconcat :: [Solid] -> Solid
mconcat = [Solid] -> Solid
unions

instance Lattice Solid where 
    /\ :: Solid -> Solid -> Solid
(/\) = Solid -> Solid -> Solid
intersection
    \/ :: Solid -> Solid -> Solid
(\/) = Solid -> Solid -> Solid
union

instance BoundedJoinSemiLattice Solid where
    bottom :: Solid
bottom = Solid
nowhere
{--
-- TODO: because everywhere doesn't work correctly
-- using the BoundedMeetSemiLattice instance
-- and by extension, the Heyting instance
-- is liable to produce invalid shapes
instance BoundedMeetSemiLattice Solid where
    top = everywhere

-- every boolean algebra is a Heyting algebra with
--  a → b defined as ¬a ∨ b
instance Heyting Solid where
    neg = complement
    a ==> b = neg a \/ b
--}