{-| 
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
    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
    return $ if isNull 
        then Nothing
        else Just shape

makeSolidFromShell :: Ptr TopoDS.Shape -> Acquire (Maybe (Ptr TopoDS.Solid))
makeSolidFromShell :: Ptr Shape -> Acquire (Maybe (Ptr Solid))
makeSolidFromShell Ptr Shape
shape = do
    t <- IO ShapeEnum -> Acquire ShapeEnum
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ShapeEnum -> Acquire ShapeEnum)
-> IO ShapeEnum -> Acquire ShapeEnum
forall a b. (a -> b) -> a -> b
$ Ptr Shape -> IO ShapeEnum
TopoDS.Shape.shapeType Ptr Shape
shape
    case t of 
        ShapeEnum
ShapeEnum.Shell -> do
            makeSolid <- Acquire (Ptr MakeSolid)
BRepBuilderAPI.MakeSolid.new 
            shapeAsShell <- liftIO $ unsafeDowncast shape
            liftIO $ BRepBuilderAPI.MakeSolid.add makeSolid shapeAsShell
            shapeAsSolid <- BRepBuilderAPI.MakeSolid.solid makeSolid
            return $ Just shapeAsSolid
        ShapeEnum
ShapeEnum.Compound -> do
            makeSolid <- Acquire (Ptr MakeSolid)
BRepBuilderAPI.MakeSolid.new 
            explorer <- TopExp.Explorer.new shape ShapeEnum.Shell
            let actionForEachShell :: Acquire ()
                actionForEachShell = do
                    shellAsShape <- 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
                    shapeAsShell <- liftIO $ unsafeDowncast shellAsShape
                    liftIO $ BRepBuilderAPI.MakeSolid.add makeSolid shapeAsShell
            let go = do
                    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
                    when isMore $ do 
                        actionForEachShell
                        liftIO $ TopExp.Explorer.next explorer
                        go
            go
            shapeAsSolid <- BRepBuilderAPI.MakeSolid.solid makeSolid
            return $ Just shapeAsSolid
        ShapeEnum
_ -> Maybe (Ptr Solid) -> Acquire (Maybe (Ptr Solid))
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Ptr Solid)
forall a. Maybe a
Nothing

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
    mesh <- Ptr Shape -> Double -> Acquire (Ptr IncrementalMesh)
BRepMesh.IncrementalMesh.fromShapeAndLinDeflection Ptr Shape
s Double
linDeflection
    liftIO $ BRepMesh.IncrementalMesh.perform mesh

    builder <- TopoDS.Builder.new
    compound <- TopoDS.Compound.new
    liftIO $ TopoDS.Builder.makeCompound builder compound
    sewing <- BRepBuilderAPI.Sewing.new 1e-6 True True True False
    explorer <- TopExp.Explorer.new s ShapeEnum.Face
    
    let actionForEachFace :: Acquire ()
        actionForEachFace = do
            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
            faceAsFace <- liftIO . unsafeDowncast $ faceAsShape
            loc <- TopLoc.Location.new
            orientation <- liftIO $ TopoDS.Shape.orientation faceAsShape
            trsf <- TopLoc.Location.toGPTrsf loc
            triangulation <- BRep.Tool.triangulation faceAsFace loc
            triCount <- liftIO $ Poly.Triangulation.nbTriangles triangulation
            forM_ [1..triCount] $ \Int
i -> do
                triangle <- Ptr (Handle Triangulation) -> Int -> Acquire (Ptr Triangle)
Poly.Triangulation.triangle Ptr (Handle Triangulation)
triangulation Int
i
                let 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 
                p1 <- p 1
                p2 <- p 2
                p3 <- p 3
                let 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
                p12Coincident <- pointsEqual p1 p2 
                p13Coincident <- pointsEqual p1 p3
                p23Coincident <- pointsEqual p2 p3
                let anyPointsCoincident = Bool
p12Coincident Bool -> Bool -> Bool
|| Bool
p13Coincident Bool -> Bool -> Bool
|| Bool
p23Coincident
                unless anyPointsCoincident $ do
                    let 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
                    polygon <- if orientation == TopAbs.Orientation.Reversed 
                        then makePolygon p1 p3 p2
                        else makePolygon p1 p2 p3
                    polygonIsNull <- liftIO $ TopoDS.Shape.isNull (upcast polygon)
                    unless polygonIsNull $ do
                        makeFace <- BRepBuilderAPI.MakeFace.fromWire polygon False
                        newFace <- BRepBuilderAPI.MakeShape.shape (upcast makeFace)
                        faceIsNull <- liftIO $ TopoDS.Shape.isNull newFace
                        unless faceIsNull $ liftIO $ TopoDS.Builder.add builder (upcast compound) newFace 

    let go = do
            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
            when isMore $ do 
                actionForEachFace
                liftIO $ TopExp.Explorer.next explorer
                go
    go
    liftIO $ BRepBuilderAPI.Sewing.load sewing (upcast compound)
    liftIO . BRepBuilderAPI.Sewing.perform $ sewing
    shape <- BRepBuilderAPI.Sewing.sewedShape sewing
    maybeShapeAsSolid <- makeSolidFromShell shape
    case maybeShapeAsSolid of
        Maybe (Ptr Solid)
Nothing -> Maybe (Ptr Shape) -> Acquire (Maybe (Ptr Shape))
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Ptr Shape)
forall a. Maybe a
Nothing
        Just Ptr Solid
shapeAsSolid -> do
            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 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 
                    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 orientable 
                        then return . Just . upcast $ shapeAsSolid
                        else return Nothing