{-# LANGUAGE  InstanceSigs #-}
module Waterfall.Internal.Path.Common 
( RawPath (..)
, joinRawPaths
, rawPathWire
) where

import Data.Acquire
import qualified OpenCascade.TopoDS as TopoDS
import qualified OpenCascade.BRepBuilderAPI.MakeWire as MakeWire
import qualified OpenCascade.BRepBuilderAPI.MakeEdge as MakeEdge
import Waterfall.Internal.Edges (joinWires, wireEndpoints)
import Waterfall.Internal.ToOpenCascade (v3ToPnt)
import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)
import Control.Monad.IO.Class (liftIO)
import Linear (V3 (..), distance)
import Foreign.Ptr
import Data.Maybe (catMaybes)
import Data.Semigroup (sconcat)
import Data.List.NonEmpty (NonEmpty ())
import Data.Foldable (toList)

data RawPath = EmptyRawPath | SinglePointRawPath (V3 Double) | ComplexRawPath (Ptr TopoDS.Wire)

rawPathWire :: RawPath -> Maybe (Ptr TopoDS.Wire)
rawPathWire :: RawPath -> Maybe (Ptr Wire)
rawPathWire (ComplexRawPath Ptr Wire
wire) = Ptr Wire -> Maybe (Ptr Wire)
forall a. a -> Maybe a
Just Ptr Wire
wire
rawPathWire RawPath
_ = Maybe (Ptr Wire)
forall a. Maybe a
Nothing

rawPathToEither :: RawPath -> Maybe (Either (V3 Double) (Ptr TopoDS.Wire))
rawPathToEither :: RawPath -> Maybe (Either (V3 Double) (Ptr Wire))
rawPathToEither RawPath
EmptyRawPath = Maybe (Either (V3 Double) (Ptr Wire))
forall a. Maybe a
Nothing
rawPathToEither (SinglePointRawPath V3 Double
p) = Either (V3 Double) (Ptr Wire)
-> Maybe (Either (V3 Double) (Ptr Wire))
forall a. a -> Maybe a
Just (Either (V3 Double) (Ptr Wire)
 -> Maybe (Either (V3 Double) (Ptr Wire)))
-> (V3 Double -> Either (V3 Double) (Ptr Wire))
-> V3 Double
-> Maybe (Either (V3 Double) (Ptr Wire))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V3 Double -> Either (V3 Double) (Ptr Wire)
forall a b. a -> Either a b
Left (V3 Double -> Maybe (Either (V3 Double) (Ptr Wire)))
-> V3 Double -> Maybe (Either (V3 Double) (Ptr Wire))
forall a b. (a -> b) -> a -> b
$ V3 Double
p
rawPathToEither (ComplexRawPath Ptr Wire
wire) = Either (V3 Double) (Ptr Wire)
-> Maybe (Either (V3 Double) (Ptr Wire))
forall a. a -> Maybe a
Just (Either (V3 Double) (Ptr Wire)
 -> Maybe (Either (V3 Double) (Ptr Wire)))
-> (Ptr Wire -> Either (V3 Double) (Ptr Wire))
-> Ptr Wire
-> Maybe (Either (V3 Double) (Ptr Wire))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Wire -> Either (V3 Double) (Ptr Wire)
forall a b. b -> Either a b
Right (Ptr Wire -> Maybe (Either (V3 Double) (Ptr Wire)))
-> Ptr Wire -> Maybe (Either (V3 Double) (Ptr Wire))
forall a b. (a -> b) -> a -> b
$ Ptr Wire
wire

line' :: V3 Double -> V3 Double -> Acquire (Ptr TopoDS.Wire)
line' :: V3 Double -> V3 Double -> Acquire (Ptr Wire)
line' V3 Double
s V3 Double
e = do
    Ptr MakeWire
builder <- Acquire (Ptr MakeWire)
MakeWire.new
    Ptr Pnt
pt1 <- V3 Double -> Acquire (Ptr Pnt)
v3ToPnt V3 Double
s
    Ptr Pnt
pt2 <- V3 Double -> Acquire (Ptr Pnt)
v3ToPnt V3 Double
e
    Ptr Edge
edge <- Ptr Pnt -> Ptr Pnt -> Acquire (Ptr Edge)
MakeEdge.fromPnts Ptr Pnt
pt1 Ptr Pnt
pt2
    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 MakeWire -> Ptr Edge -> IO ()
MakeWire.addEdge Ptr MakeWire
builder Ptr Edge
edge
    Ptr MakeWire -> Acquire (Ptr Wire)
MakeWire.wire Ptr MakeWire
builder
    
intersperseLines :: [Either (V3 Double) (Ptr TopoDS.Wire)] -> Acquire [Ptr TopoDS.Wire]
intersperseLines :: [Either (V3 Double) (Ptr Wire)] -> Acquire [Ptr Wire]
intersperseLines [] = [Ptr Wire] -> Acquire [Ptr Wire]
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
intersperseLines [Left V3 Double
_x] = [Ptr Wire] -> Acquire [Ptr Wire]
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
intersperseLines [Right Ptr Wire
x] = [Ptr Wire] -> Acquire [Ptr Wire]
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Ptr Wire
x]
intersperseLines (Either (V3 Double) (Ptr Wire)
a:Either (V3 Double) (Ptr Wire)
b:[Either (V3 Double) (Ptr Wire)]
xs) = do
    V3 Double
ea <- case Either (V3 Double) (Ptr Wire)
a of 
            Left V3 Double
pnt -> V3 Double -> Acquire (V3 Double)
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure V3 Double
pnt
            Right Ptr Wire
wire -> do
                Ptr Wire
wire' <- Ptr Wire -> Acquire (Ptr Wire)
forall a. a -> Acquire a
toAcquire Ptr Wire
wire
                IO (V3 Double) -> Acquire (V3 Double)
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (V3 Double) -> Acquire (V3 Double))
-> IO (V3 Double) -> Acquire (V3 Double)
forall a b. (a -> b) -> a -> b
$ (V3 Double, V3 Double) -> V3 Double
forall a b. (a, b) -> b
snd ((V3 Double, V3 Double) -> V3 Double)
-> IO (V3 Double, V3 Double) -> IO (V3 Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Wire -> IO (V3 Double, V3 Double)
wireEndpoints Ptr Wire
wire'
    V3 Double
sb <- case Either (V3 Double) (Ptr Wire)
b of
            Left V3 Double
pnt -> V3 Double -> Acquire (V3 Double)
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure V3 Double
pnt 
            Right Ptr Wire
wire -> IO (V3 Double) -> Acquire (V3 Double)
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (V3 Double) -> Acquire (V3 Double))
-> IO (V3 Double) -> Acquire (V3 Double)
forall a b. (a -> b) -> a -> b
$ (V3 Double, V3 Double) -> V3 Double
forall a b. (a, b) -> a
fst ((V3 Double, V3 Double) -> V3 Double)
-> IO (V3 Double, V3 Double) -> IO (V3 Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Wire -> IO (V3 Double, V3 Double)
wireEndpoints Ptr Wire
wire
    let prependA :: [Ptr Wire] -> [Ptr Wire]
prependA = (V3 Double -> [Ptr Wire] -> [Ptr Wire])
-> (Ptr Wire -> [Ptr Wire] -> [Ptr Wire])
-> Either (V3 Double) (Ptr Wire)
-> [Ptr Wire]
-> [Ptr Wire]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (([Ptr Wire] -> [Ptr Wire]) -> V3 Double -> [Ptr Wire] -> [Ptr Wire]
forall a b. a -> b -> a
const [Ptr Wire] -> [Ptr Wire]
forall a. a -> a
id) (:) Either (V3 Double) (Ptr Wire)
a
    if V3 Double -> V3 Double -> Double
forall a. Floating a => V3 a -> V3 a -> a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a -> a
distance V3 Double
ea V3 Double
sb Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1e-6
            then [Ptr Wire] -> [Ptr Wire]
prependA ([Ptr Wire] -> [Ptr Wire])
-> Acquire [Ptr Wire] -> Acquire [Ptr Wire]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Either (V3 Double) (Ptr Wire)] -> Acquire [Ptr Wire]
intersperseLines (Either (V3 Double) (Ptr Wire)
bEither (V3 Double) (Ptr Wire)
-> [Either (V3 Double) (Ptr Wire)]
-> [Either (V3 Double) (Ptr Wire)]
forall a. a -> [a] -> [a]
:[Either (V3 Double) (Ptr Wire)]
xs)
            else [Ptr Wire] -> [Ptr Wire]
prependA ([Ptr Wire] -> [Ptr Wire])
-> Acquire [Ptr Wire] -> Acquire [Ptr Wire]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((:) (Ptr Wire -> [Ptr Wire] -> [Ptr Wire])
-> Acquire (Ptr Wire) -> Acquire ([Ptr Wire] -> [Ptr Wire])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V3 Double -> V3 Double -> Acquire (Ptr Wire)
line' V3 Double
ea V3 Double
sb Acquire ([Ptr Wire] -> [Ptr Wire])
-> Acquire [Ptr Wire] -> Acquire [Ptr Wire]
forall a b. Acquire (a -> b) -> Acquire a -> Acquire b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Either (V3 Double) (Ptr Wire)] -> Acquire [Ptr Wire]
intersperseLines (Either (V3 Double) (Ptr Wire)
bEither (V3 Double) (Ptr Wire)
-> [Either (V3 Double) (Ptr Wire)]
-> [Either (V3 Double) (Ptr Wire)]
forall a. a -> [a] -> [a]
:[Either (V3 Double) (Ptr Wire)]
xs))

joinRawPaths :: [RawPath] -> RawPath
joinRawPaths :: [RawPath] -> RawPath
joinRawPaths [RawPath]
paths = 
    case [Maybe (Either (V3 Double) (Ptr Wire))]
-> [Either (V3 Double) (Ptr Wire)]
forall a. [Maybe a] -> [a]
catMaybes (RawPath -> Maybe (Either (V3 Double) (Ptr Wire))
rawPathToEither (RawPath -> Maybe (Either (V3 Double) (Ptr Wire)))
-> [RawPath] -> [Maybe (Either (V3 Double) (Ptr Wire))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawPath]
paths) of
        [] -> RawPath
EmptyRawPath
        [Left V3 Double
pnt] -> V3 Double -> RawPath
SinglePointRawPath V3 Double
pnt
        path :: [Either (V3 Double) (Ptr Wire)]
path@(Either (V3 Double) (Ptr Wire)
h:[Either (V3 Double) (Ptr Wire)]
_) -> Acquire RawPath -> RawPath
forall a. Acquire a -> a
unsafeFromAcquire (Acquire RawPath -> RawPath) -> Acquire RawPath -> RawPath
forall a b. (a -> b) -> a -> b
$ do
            [Ptr Wire]
interspersed <- [Either (V3 Double) (Ptr Wire)] -> Acquire [Ptr Wire]
intersperseLines [Either (V3 Double) (Ptr Wire)]
path
            case [Ptr Wire]
interspersed of 
                [] -> RawPath -> Acquire RawPath
forall a. a -> Acquire a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawPath -> Acquire RawPath)
-> (Either (V3 Double) (Ptr Wire) -> RawPath)
-> Either (V3 Double) (Ptr Wire)
-> Acquire RawPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V3 Double -> RawPath)
-> (Ptr Wire -> RawPath)
-> Either (V3 Double) (Ptr Wire)
-> RawPath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either V3 Double -> RawPath
SinglePointRawPath Ptr Wire -> RawPath
ComplexRawPath (Either (V3 Double) (Ptr Wire) -> Acquire RawPath)
-> Either (V3 Double) (Ptr Wire) -> Acquire RawPath
forall a b. (a -> b) -> a -> b
$ Either (V3 Double) (Ptr Wire)
h
                [Ptr Wire]
wires -> Ptr Wire -> RawPath
ComplexRawPath (Ptr Wire -> RawPath) -> Acquire (Ptr Wire) -> Acquire RawPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ptr Wire] -> Acquire (Ptr Wire)
joinWires [Ptr Wire]
wires

instance Semigroup RawPath where
    sconcat :: NonEmpty RawPath -> RawPath
    sconcat :: NonEmpty RawPath -> RawPath
sconcat = [RawPath] -> RawPath
joinRawPaths ([RawPath] -> RawPath)
-> (NonEmpty RawPath -> [RawPath]) -> NonEmpty RawPath -> RawPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty RawPath -> [RawPath]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
    (<>) :: RawPath -> RawPath -> RawPath
    RawPath
a <> :: RawPath -> RawPath -> RawPath
<> RawPath
b = [RawPath] -> RawPath
joinRawPaths [RawPath
a, RawPath
b]
    
instance Monoid RawPath where
    mempty :: RawPath
    mempty :: RawPath
mempty = RawPath
EmptyRawPath
    mconcat :: [RawPath] -> RawPath
    mconcat :: [RawPath] -> RawPath
mconcat = [RawPath] -> RawPath
joinRawPaths