{-| 
Module: Waterfall.Internal.Remesh

This code exists because the opencascade GLTF loading code generates "weird" BReps

The FreeCAD sourcecode describes this as follows:

> The glTF reader creates a compound of faces that only contains the triangulation
> but not the underlying surfaces. This leads to faces without boundaries.
> The triangulation is used to create a valid shape.

The practical result of this, seems to be that directly using an `OpenCascade.TopoDS.Shape` 
loaded using `OpenCascade.RWGltf.CafReader` in most operations will lead to segmentation faults.

However, we can safely access the Triangulation of the Shape, construct Polygons from this
and then use BReps derived from these Polygons.

In this way, the `remesh` function produces a new Boundary Represenation from the Mesh of an `OpenCascade.TopoDS.Shape`

-}
module Waterfall.Internal.Remesh 
( remesh 
) where

import qualified OpenCascade.GP.Pnt as GP.Pnt
import qualified OpenCascade.TopoDS as TopoDS
import qualified OpenCascade.TopoDS.Shape as TopoDS.Shape
import qualified OpenCascade.TopoDS.Compound as TopoDS.Compound
import qualified OpenCascade.TopExp.Explorer as TopExp.Explorer
import qualified OpenCascade.TopAbs.ShapeEnum as ShapeEnum
import qualified OpenCascade.TopAbs.Orientation as TopAbs.Orientation
import qualified OpenCascade.BRepBuilderAPI.Sewing as BRepBuilderAPI.Sewing
import qualified OpenCascade.BRepBuilderAPI.MakePolygon as BRepBuilderAPI.MakePolygon
import qualified OpenCascade.BRepBuilderAPI.MakeFace as BRepBuilderAPI.MakeFace
import qualified OpenCascade.BRepBuilderAPI.MakeSolid as BRepBuilderAPI.MakeSolid
import qualified OpenCascade.BRepBuilderAPI.MakeShape as BRepBuilderAPI.MakeShape
import qualified OpenCascade.BRep.Tool as BRep.Tool
import qualified OpenCascade.BRepLib as BRepLib
import qualified OpenCascade.TopoDS.Builder as TopoDS.Builder
import qualified OpenCascade.BRepMesh.IncrementalMesh as BRepMesh.IncrementalMesh
import qualified OpenCascade.Poly.Triangulation as Poly.Triangulation
import qualified OpenCascade.Poly.Triangle as Poly.Triangle
import qualified OpenCascade.TopLoc.Location as TopLoc.Location
import OpenCascade.Inheritance (upcast, unsafeDowncast)
import Foreign.Ptr (Ptr)
import Data.Acquire (Acquire)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad (when, unless, forM_, (<=<))


checkNonNull:: MonadIO m => Ptr TopoDS.Shape -> m (Maybe (Ptr TopoDS.Shape))
checkNonNull :: forall (m :: * -> *).
MonadIO m =>
Ptr Shape -> m (Maybe (Ptr Shape))
checkNonNull Ptr Shape
shape = do
    Bool
isNull <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool)
-> (Ptr Shape -> IO Bool) -> Ptr Shape -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO Bool
TopoDS.Shape.isNull (Ptr Shape -> m Bool) -> Ptr Shape -> m Bool
forall a b. (a -> b) -> a -> b
$ Ptr Shape
shape
    Maybe (Ptr Shape) -> m (Maybe (Ptr Shape))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ptr Shape) -> m (Maybe (Ptr Shape)))
-> Maybe (Ptr Shape) -> m (Maybe (Ptr Shape))
forall a b. (a -> b) -> a -> b
$ if Bool
isNull 
        then Maybe (Ptr Shape)
forall a. Maybe a
Nothing
        else Ptr Shape -> Maybe (Ptr Shape)
forall a. a -> Maybe a
Just Ptr Shape
shape

remesh :: Ptr TopoDS.Shape -> Acquire (Maybe (Ptr TopoDS.Shape))
remesh :: Ptr Shape -> Acquire (Maybe (Ptr Shape))
remesh Ptr Shape
s = do

    let linDeflection :: Double
linDeflection = Double
0.01
    Ptr IncrementalMesh
mesh <- Ptr Shape -> Double -> Acquire (Ptr IncrementalMesh)
BRepMesh.IncrementalMesh.fromShapeAndLinDeflection Ptr Shape
s Double
linDeflection
    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
$ Ptr IncrementalMesh -> IO ()
BRepMesh.IncrementalMesh.perform Ptr IncrementalMesh
mesh

    Ptr Builder
builder <- Acquire (Ptr Builder)
TopoDS.Builder.new
    Ptr Compound
compound <- Acquire (Ptr Compound)
TopoDS.Compound.new
    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
$ Ptr Builder -> Ptr Compound -> IO ()
TopoDS.Builder.makeCompound Ptr Builder
builder Ptr Compound
compound
    Ptr Sewing
sewing <- Double -> Bool -> Bool -> Bool -> Bool -> Acquire (Ptr Sewing)
BRepBuilderAPI.Sewing.new Double
1e-6 Bool
True Bool
True Bool
True Bool
False
    Ptr Explorer
explorer <- Ptr Shape -> ShapeEnum -> Acquire (Ptr Explorer)
TopExp.Explorer.new Ptr Shape
s ShapeEnum
ShapeEnum.Face
    
    let actionForEachFace :: Acquire ()
        actionForEachFace :: Acquire ()
actionForEachFace = do
            Ptr Shape
faceAsShape <- IO (Ptr Shape) -> Acquire (Ptr Shape)
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Shape) -> Acquire (Ptr Shape))
-> IO (Ptr Shape) -> Acquire (Ptr Shape)
forall a b. (a -> b) -> a -> b
$ Ptr Explorer -> IO (Ptr Shape)
TopExp.Explorer.value Ptr Explorer
explorer
            Ptr Face
faceAsFace <- IO (Ptr Face) -> Acquire (Ptr Face)
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Face) -> Acquire (Ptr Face))
-> (Ptr Shape -> IO (Ptr Face)) -> Ptr Shape -> Acquire (Ptr Face)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO (Ptr Face)
forall a b. DiscriminatedSubTypeOf a b => Ptr a -> IO (Ptr b)
unsafeDowncast (Ptr Shape -> Acquire (Ptr Face))
-> Ptr Shape -> Acquire (Ptr Face)
forall a b. (a -> b) -> a -> b
$ Ptr Shape
faceAsShape
            Ptr Location
loc <- Acquire (Ptr Location)
TopLoc.Location.new
            Orientation
orientation <- IO Orientation -> Acquire Orientation
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Orientation -> Acquire Orientation)
-> IO Orientation -> Acquire Orientation
forall a b. (a -> b) -> a -> b
$ Ptr Shape -> IO Orientation
TopoDS.Shape.orientation Ptr Shape
faceAsShape
            Ptr Trsf
trsf <- Ptr Location -> Acquire (Ptr Trsf)
TopLoc.Location.toGPTrsf Ptr Location
loc
            Ptr (Handle Triangulation)
triangulation <- Ptr Face -> Ptr Location -> Acquire (Ptr (Handle Triangulation))
BRep.Tool.triangulation Ptr Face
faceAsFace Ptr Location
loc
            Int
triCount <- IO Int -> Acquire Int
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> Acquire Int) -> IO Int -> Acquire Int
forall a b. (a -> b) -> a -> b
$ Ptr (Handle Triangulation) -> IO Int
Poly.Triangulation.nbTriangles Ptr (Handle Triangulation)
triangulation
            [Int] -> (Int -> Acquire ()) -> Acquire ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
triCount] ((Int -> Acquire ()) -> Acquire ())
-> (Int -> Acquire ()) -> Acquire ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
                Ptr Triangle
triangle <- Ptr (Handle Triangulation) -> Int -> Acquire (Ptr Triangle)
Poly.Triangulation.triangle Ptr (Handle Triangulation)
triangulation Int
i
                let p :: Int -> Acquire (Ptr Pnt)
p = (Ptr Pnt -> Ptr Trsf -> Acquire (Ptr Pnt)
`GP.Pnt.transformed` Ptr Trsf
trsf) (Ptr Pnt -> Acquire (Ptr Pnt))
-> (Int -> Acquire (Ptr Pnt)) -> Int -> Acquire (Ptr Pnt)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Ptr (Handle Triangulation) -> Int -> Acquire (Ptr Pnt)
Poly.Triangulation.node Ptr (Handle Triangulation)
triangulation (Int -> Acquire (Ptr Pnt))
-> (Int -> Acquire Int) -> Int -> Acquire (Ptr Pnt)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO Int -> Acquire Int
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> Acquire Int) -> (Int -> IO Int) -> Int -> Acquire Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Triangle -> Int -> IO Int
Poly.Triangle.value Ptr Triangle
triangle 
                Ptr Pnt
p1 <- Int -> Acquire (Ptr Pnt)
p Int
1
                Ptr Pnt
p2 <- Int -> Acquire (Ptr Pnt)
p Int
2
                Ptr Pnt
p3 <- Int -> Acquire (Ptr Pnt)
p Int
3
                let pointsEqual :: Ptr Pnt -> Ptr Pnt -> m Bool
pointsEqual Ptr Pnt
a Ptr Pnt
b = IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Ptr Pnt -> Ptr Pnt -> Double -> IO Bool
GP.Pnt.isEqual Ptr Pnt
a Ptr Pnt
b Double
0
                Bool
p12Coincident <- Ptr Pnt -> Ptr Pnt -> Acquire Bool
forall {m :: * -> *}. MonadIO m => Ptr Pnt -> Ptr Pnt -> m Bool
pointsEqual Ptr Pnt
p1 Ptr Pnt
p2 
                Bool
p13Coincident <- Ptr Pnt -> Ptr Pnt -> Acquire Bool
forall {m :: * -> *}. MonadIO m => Ptr Pnt -> Ptr Pnt -> m Bool
pointsEqual Ptr Pnt
p1 Ptr Pnt
p3
                Bool
p23Coincident <- Ptr Pnt -> Ptr Pnt -> Acquire Bool
forall {m :: * -> *}. MonadIO m => Ptr Pnt -> Ptr Pnt -> m Bool
pointsEqual Ptr Pnt
p2 Ptr Pnt
p3
                let anyPointsCoincident :: Bool
anyPointsCoincident = Bool
p12Coincident Bool -> Bool -> Bool
|| Bool
p13Coincident Bool -> Bool -> Bool
|| Bool
p23Coincident
                Bool -> Acquire () -> Acquire ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
anyPointsCoincident (Acquire () -> Acquire ()) -> Acquire () -> Acquire ()
forall a b. (a -> b) -> a -> b
$ do
                    let makePolygon :: Ptr Pnt -> Ptr Pnt -> Ptr Pnt -> Acquire (Ptr Wire)
makePolygon Ptr Pnt
p1' Ptr Pnt
p2' Ptr Pnt
p3' = Ptr Pnt -> Ptr Pnt -> Ptr Pnt -> Bool -> Acquire (Ptr Wire)
BRepBuilderAPI.MakePolygon.from3Pnts Ptr Pnt
p1' Ptr Pnt
p2' Ptr Pnt
p3' Bool
True
                    Ptr Wire
polygon <- if Orientation
orientation Orientation -> Orientation -> Bool
forall a. Eq a => a -> a -> Bool
== Orientation
TopAbs.Orientation.Reversed 
                        then Ptr Pnt -> Ptr Pnt -> Ptr Pnt -> Acquire (Ptr Wire)
makePolygon Ptr Pnt
p1 Ptr Pnt
p3 Ptr Pnt
p2
                        else Ptr Pnt -> Ptr Pnt -> Ptr Pnt -> Acquire (Ptr Wire)
makePolygon Ptr Pnt
p1 Ptr Pnt
p2 Ptr Pnt
p3
                    Bool
polygonIsNull <- IO Bool -> Acquire Bool
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Acquire Bool) -> IO Bool -> Acquire Bool
forall a b. (a -> b) -> a -> b
$ Ptr Shape -> IO Bool
TopoDS.Shape.isNull (Ptr Wire -> Ptr Shape
forall a b. SubTypeOf a b => Ptr b -> Ptr a
upcast Ptr Wire
polygon)
                    Bool -> Acquire () -> Acquire ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
polygonIsNull (Acquire () -> Acquire ()) -> Acquire () -> Acquire ()
forall a b. (a -> b) -> a -> b
$ do
                        Ptr MakeFace
makeFace <- Ptr Wire -> Bool -> Acquire (Ptr MakeFace)
BRepBuilderAPI.MakeFace.fromWire Ptr Wire
polygon Bool
False
                        Ptr Shape
newFace <- Ptr MakeShape -> Acquire (Ptr Shape)
BRepBuilderAPI.MakeShape.shape (Ptr MakeFace -> Ptr MakeShape
forall a b. SubTypeOf a b => Ptr b -> Ptr a
upcast Ptr MakeFace
makeFace)
                        Bool
faceIsNull <- IO Bool -> Acquire Bool
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Acquire Bool) -> IO Bool -> Acquire Bool
forall a b. (a -> b) -> a -> b
$ Ptr Shape -> IO Bool
TopoDS.Shape.isNull Ptr Shape
newFace
                        Bool -> Acquire () -> Acquire ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
faceIsNull (Acquire () -> Acquire ()) -> Acquire () -> Acquire ()
forall a b. (a -> b) -> a -> b
$ 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
$ Ptr Builder -> Ptr Shape -> Ptr Shape -> IO ()
TopoDS.Builder.add Ptr Builder
builder (Ptr Compound -> Ptr Shape
forall a b. SubTypeOf a b => Ptr b -> Ptr a
upcast Ptr Compound
compound) Ptr Shape
newFace 

    let go :: Acquire ()
go = do
            Bool
isMore <- IO Bool -> Acquire Bool
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Acquire Bool) -> IO Bool -> Acquire Bool
forall a b. (a -> b) -> a -> b
$ Ptr Explorer -> IO Bool
TopExp.Explorer.more Ptr Explorer
explorer
            Bool -> Acquire () -> Acquire ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isMore (Acquire () -> Acquire ()) -> Acquire () -> Acquire ()
forall a b. (a -> b) -> a -> b
$ do 
                Acquire ()
actionForEachFace
                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
$ Ptr Explorer -> IO ()
TopExp.Explorer.next Ptr Explorer
explorer
                Acquire ()
go
    Acquire ()
go
    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
$ Ptr Sewing -> Ptr Shape -> IO ()
BRepBuilderAPI.Sewing.load Ptr Sewing
sewing (Ptr Compound -> Ptr Shape
forall a b. SubTypeOf a b => Ptr b -> Ptr a
upcast Ptr Compound
compound)
    IO () -> Acquire ()
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Acquire ())
-> (Ptr Sewing -> IO ()) -> Ptr Sewing -> Acquire ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Sewing -> IO ()
BRepBuilderAPI.Sewing.perform (Ptr Sewing -> Acquire ()) -> Ptr Sewing -> Acquire ()
forall a b. (a -> b) -> a -> b
$ Ptr Sewing
sewing
    Ptr Shape
shape <- Ptr Sewing -> Acquire (Ptr Shape)
BRepBuilderAPI.Sewing.sewedShape Ptr Sewing
sewing
    Ptr MakeSolid
makeSolid <- Acquire (Ptr MakeSolid)
BRepBuilderAPI.MakeSolid.new 
    Ptr Shell
shapeAsShell <- IO (Ptr Shell) -> Acquire (Ptr Shell)
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Shell) -> Acquire (Ptr Shell))
-> IO (Ptr Shell) -> Acquire (Ptr Shell)
forall a b. (a -> b) -> a -> b
$ Ptr Shape -> IO (Ptr Shell)
forall a b. DiscriminatedSubTypeOf a b => Ptr a -> IO (Ptr b)
unsafeDowncast Ptr Shape
shape
    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
$ Ptr MakeSolid -> Ptr Shell -> IO ()
BRepBuilderAPI.MakeSolid.add Ptr MakeSolid
makeSolid Ptr Shell
shapeAsShell
    Ptr Solid
shapeAsSolid <- Ptr MakeSolid -> Acquire (Ptr Solid)
BRepBuilderAPI.MakeSolid.solid Ptr MakeSolid
makeSolid
    Maybe (Ptr Shape)
maybeNotNull <- Ptr Shape -> Acquire (Maybe (Ptr Shape))
forall (m :: * -> *).
MonadIO m =>
Ptr Shape -> m (Maybe (Ptr Shape))
checkNonNull (Ptr Solid -> Ptr Shape
forall a b. SubTypeOf a b => Ptr b -> Ptr a
upcast Ptr Solid
shapeAsSolid)
    case Maybe (Ptr Shape)
maybeNotNull of
        Maybe (Ptr Shape)
Nothing -> Maybe (Ptr Shape) -> Acquire (Maybe (Ptr Shape))
forall a. a -> Acquire a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Ptr Shape)
forall a. Maybe a
Nothing
        Just Ptr Shape
_ -> do 
            Bool
orientable <- IO Bool -> Acquire Bool
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Acquire Bool) -> IO Bool -> Acquire Bool
forall a b. (a -> b) -> a -> b
$ Ptr Solid -> IO Bool
BRepLib.orientClosedSolid (Ptr Solid
shapeAsSolid)
            if Bool
orientable 
                then Maybe (Ptr Shape) -> Acquire (Maybe (Ptr Shape))
forall a. a -> Acquire a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ptr Shape) -> Acquire (Maybe (Ptr Shape)))
-> (Ptr Solid -> Maybe (Ptr Shape))
-> Ptr Solid
-> Acquire (Maybe (Ptr Shape))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> Maybe (Ptr Shape)
forall a. a -> Maybe a
Just (Ptr Shape -> Maybe (Ptr Shape))
-> (Ptr Solid -> Ptr Shape) -> Ptr Solid -> Maybe (Ptr Shape)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Solid -> Ptr Shape
forall a b. SubTypeOf a b => Ptr b -> Ptr a
upcast (Ptr Solid -> Acquire (Maybe (Ptr Shape)))
-> Ptr Solid -> Acquire (Maybe (Ptr Shape))
forall a b. (a -> b) -> a -> b
$ Ptr Solid
shapeAsSolid
                else Maybe (Ptr Shape) -> Acquire (Maybe (Ptr Shape))
forall a. a -> Acquire a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Ptr Shape)
forall a. Maybe a
Nothing