{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE InstanceSigs #-}
module Waterfall.Internal.Solid 
( Solid (..)
, acquireSolid
, solidFromAcquire
, union
, difference
, intersection
, 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 OpenCascade.Inheritance (upcast)
import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)

-- | 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

-- | 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

-- | 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

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
--}