{-# Language OverloadedStrings #-}
{-|
Convert "Waterfall" data into [SVG](https://developer.mozilla.org/en-US/docs/Web/SVG)
-}
module Waterfall.SVG.ToSVG
( path2DToPathCommands
, diagramToSvg
, writeDiagramSVG
) where

import qualified Waterfall
import qualified Graphics.Svg as Svg
import qualified Graphics.Svg.CssTypes as Svg.Css
import Linear (_xy, _x, _y, V2 (..), nearZero)
import Control.Lens ((^.), (&), (.~))
import Foreign.Ptr (Ptr)
import Control.Monad ((<=<)) 
import Control.Monad.IO.Class (liftIO)
import Waterfall.TwoD.Internal.Path2D (Path2D (..))
import Waterfall.Internal.FromOpenCascade (gpPntToV3)
import qualified Waterfall.Internal.Path.Common as Internal.Path.Common
import qualified Waterfall.Internal.Edges as Internal.Edges
import qualified Waterfall.Internal.Finalizers as Internal.Finalizers
import qualified OpenCascade.TopoDS as TopoDS
import qualified OpenCascade.BRepAdaptor.Curve as BRepAdaptor.Curve
import qualified OpenCascade.Geom as Geom
import qualified OpenCascade.GeomAbs.CurveType as GeomAbs.CurveType
import qualified OpenCascade.Geom.BezierCurve as Geom.BezierCurve
import qualified OpenCascade.Geom.BSplineCurve as Geom.BSplineCurve
import qualified OpenCascade.GeomAbs.Shape as GeomAbs.Shape
import qualified OpenCascade.GeomConvert.BSplineCurveToBezierCurve as GeomConvert.BSplineCurveToBezierCurve
import qualified OpenCascade.GeomConvert.ApproxCurve as GeomConvert.ApproxCurve
import qualified OpenCascade.ShapeConstruct.Curve as ShapeConstruct.Curve
import qualified OpenCascade.BRep.Tool as BRep.Tool
import OpenCascade.Handle (Handle)
import OpenCascade.Inheritance (upcast)
import Data.Acquire (Acquire)
import Codec.Picture.Types (PixelRGBA8 (..))

lineToPathCommand :: Ptr TopoDS.Edge -> IO [Svg.PathCommand]
lineToPathCommand :: Ptr Edge -> IO [PathCommand]
lineToPathCommand Ptr Edge
edge = do
    (V3 Double
_s, V3 Double
e) <- Ptr Edge -> IO (V3 Double, V3 Double)
Internal.Edges.edgeEndpoints Ptr Edge
edge
    [PathCommand] -> IO [PathCommand]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return 
        [ Origin -> [RPoint] -> PathCommand
Svg.LineTo Origin
Svg.OriginAbsolute ([RPoint] -> PathCommand)
-> (RPoint -> [RPoint]) -> RPoint -> PathCommand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPoint -> [RPoint]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RPoint -> PathCommand) -> RPoint -> PathCommand
forall a b. (a -> b) -> a -> b
$ V3 Double
e V3 Double -> Getting RPoint (V3 Double) RPoint -> RPoint
forall s a. s -> Getting a s a -> a
^. Getting RPoint (V3 Double) RPoint
forall a. Lens' (V3 a) (V2 a)
forall (t :: * -> *) a. R2 t => Lens' (t a) (V2 a)
_xy
        ]

bezierCurveToPathCommand :: Ptr TopoDS.Edge -> Ptr (Handle Geom.BezierCurve) -> Acquire [Svg.PathCommand]
bezierCurveToPathCommand :: Ptr Edge -> Ptr (Handle BezierCurve) -> Acquire [PathCommand]
bezierCurveToPathCommand Ptr Edge
edge Ptr (Handle BezierCurve)
bezier = do
    Bool
isRational <- 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 (Handle BezierCurve) -> IO Bool
Geom.BezierCurve.isRational Ptr (Handle BezierCurve)
bezier
    Int
nbPoles <- 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 BezierCurve) -> IO Int
Geom.BezierCurve.nbPoles Ptr (Handle BezierCurve)
bezier
    if Int
nbPoles Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4 Bool -> Bool -> Bool
|| Bool
isRational
        then IO [PathCommand] -> Acquire [PathCommand]
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [PathCommand] -> Acquire [PathCommand])
-> IO [PathCommand] -> Acquire [PathCommand]
forall a b. (a -> b) -> a -> b
$ Ptr Edge -> IO [PathCommand]
discretizedEdgePathCommand Ptr Edge
edge
        else do 
            [V3 Double]
poles <- (Int -> Acquire (V3 Double)) -> [Int] -> Acquire [V3 Double]
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 ((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))
-> (Ptr Pnt -> IO (V3 Double)) -> Ptr Pnt -> Acquire (V3 Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Pnt -> IO (V3 Double)
gpPntToV3) (Ptr Pnt -> Acquire (V3 Double))
-> (Int -> Acquire (Ptr Pnt)) -> Int -> Acquire (V3 Double)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Ptr (Handle BezierCurve) -> Int -> Acquire (Ptr Pnt)
Geom.BezierCurve.pole Ptr (Handle BezierCurve)
bezier) [Int
1..Int
nbPoles]
            case [V3 Double]
poles of 
                [V3 Double
_s, V3 Double
e] -> [PathCommand] -> Acquire [PathCommand]
forall a. a -> Acquire a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PathCommand] -> Acquire [PathCommand])
-> (RPoint -> [PathCommand]) -> RPoint -> Acquire [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathCommand -> [PathCommand]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathCommand -> [PathCommand])
-> (RPoint -> PathCommand) -> RPoint -> [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        Origin -> [RPoint] -> PathCommand
Svg.LineTo Origin
Svg.OriginAbsolute ([RPoint] -> PathCommand)
-> (RPoint -> [RPoint]) -> RPoint -> PathCommand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPoint -> [RPoint]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RPoint -> Acquire [PathCommand])
-> RPoint -> Acquire [PathCommand]
forall a b. (a -> b) -> a -> b
$ V3 Double
e V3 Double -> Getting RPoint (V3 Double) RPoint -> RPoint
forall s a. s -> Getting a s a -> a
^. Getting RPoint (V3 Double) RPoint
forall a. Lens' (V3 a) (V2 a)
forall (t :: * -> *) a. R2 t => Lens' (t a) (V2 a)
_xy
                [V3 Double
_s, V3 Double
cp, V3 Double
e] -> [PathCommand] -> Acquire [PathCommand]
forall a. a -> Acquire a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PathCommand] -> Acquire [PathCommand])
-> ((RPoint, RPoint) -> [PathCommand])
-> (RPoint, RPoint)
-> Acquire [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathCommand -> [PathCommand]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathCommand -> [PathCommand])
-> ((RPoint, RPoint) -> PathCommand)
-> (RPoint, RPoint)
-> [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        Origin -> [(RPoint, RPoint)] -> PathCommand
Svg.QuadraticBezier Origin
Svg.OriginAbsolute ([(RPoint, RPoint)] -> PathCommand)
-> ((RPoint, RPoint) -> [(RPoint, RPoint)])
-> (RPoint, RPoint)
-> PathCommand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RPoint, RPoint) -> [(RPoint, RPoint)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((RPoint, RPoint) -> Acquire [PathCommand])
-> (RPoint, RPoint) -> Acquire [PathCommand]
forall a b. (a -> b) -> a -> b
$ (V3 Double
cp V3 Double -> Getting RPoint (V3 Double) RPoint -> RPoint
forall s a. s -> Getting a s a -> a
^. Getting RPoint (V3 Double) RPoint
forall a. Lens' (V3 a) (V2 a)
forall (t :: * -> *) a. R2 t => Lens' (t a) (V2 a)
_xy, V3 Double
e V3 Double -> Getting RPoint (V3 Double) RPoint -> RPoint
forall s a. s -> Getting a s a -> a
^. Getting RPoint (V3 Double) RPoint
forall a. Lens' (V3 a) (V2 a)
forall (t :: * -> *) a. R2 t => Lens' (t a) (V2 a)
_xy)
                [V3 Double
_s, V3 Double
cp1, V3 Double
cp2, V3 Double
e] -> [PathCommand] -> Acquire [PathCommand]
forall a. a -> Acquire a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PathCommand] -> Acquire [PathCommand])
-> ((RPoint, RPoint, RPoint) -> [PathCommand])
-> (RPoint, RPoint, RPoint)
-> Acquire [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathCommand -> [PathCommand]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathCommand -> [PathCommand])
-> ((RPoint, RPoint, RPoint) -> PathCommand)
-> (RPoint, RPoint, RPoint)
-> [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        Origin -> [(RPoint, RPoint, RPoint)] -> PathCommand
Svg.CurveTo Origin
Svg.OriginAbsolute ([(RPoint, RPoint, RPoint)] -> PathCommand)
-> ((RPoint, RPoint, RPoint) -> [(RPoint, RPoint, RPoint)])
-> (RPoint, RPoint, RPoint)
-> PathCommand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RPoint, RPoint, RPoint) -> [(RPoint, RPoint, RPoint)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((RPoint, RPoint, RPoint) -> Acquire [PathCommand])
-> (RPoint, RPoint, RPoint) -> Acquire [PathCommand]
forall a b. (a -> b) -> a -> b
$ (V3 Double
cp1 V3 Double -> Getting RPoint (V3 Double) RPoint -> RPoint
forall s a. s -> Getting a s a -> a
^. Getting RPoint (V3 Double) RPoint
forall a. Lens' (V3 a) (V2 a)
forall (t :: * -> *) a. R2 t => Lens' (t a) (V2 a)
_xy, V3 Double
cp2 V3 Double -> Getting RPoint (V3 Double) RPoint -> RPoint
forall s a. s -> Getting a s a -> a
^. Getting RPoint (V3 Double) RPoint
forall a. Lens' (V3 a) (V2 a)
forall (t :: * -> *) a. R2 t => Lens' (t a) (V2 a)
_xy, V3 Double
e V3 Double -> Getting RPoint (V3 Double) RPoint -> RPoint
forall s a. s -> Getting a s a -> a
^. Getting RPoint (V3 Double) RPoint
forall a. Lens' (V3 a) (V2 a)
forall (t :: * -> *) a. R2 t => Lens' (t a) (V2 a)
_xy)
                [V3 Double]
_ -> IO [PathCommand] -> Acquire [PathCommand]
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [PathCommand] -> Acquire [PathCommand])
-> IO [PathCommand] -> Acquire [PathCommand]
forall a b. (a -> b) -> a -> b
$ Ptr Edge -> IO [PathCommand]
discretizedEdgePathCommand Ptr Edge
edge

bezierToPathCommand :: Ptr TopoDS.Edge -> Ptr BRepAdaptor.Curve.Curve -> Acquire [Svg.PathCommand]
bezierToPathCommand :: Ptr Edge -> Ptr Curve -> Acquire [PathCommand]
bezierToPathCommand Ptr Edge
edge Ptr Curve
curve = do 
    Double
firstParam <- IO Double -> Acquire Double
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> Acquire Double) -> IO Double -> Acquire Double
forall a b. (a -> b) -> a -> b
$ Ptr Edge -> IO Double
BRep.Tool.curveParamFirst Ptr Edge
edge
    Double
lastParam <- IO Double -> Acquire Double
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> Acquire Double) -> IO Double -> Acquire Double
forall a b. (a -> b) -> a -> b
$ Ptr Edge -> IO Double
BRep.Tool.curveParamLast Ptr Edge
edge
    Ptr (Handle BezierCurve)
bezier <- Ptr Curve -> Acquire (Ptr (Handle BezierCurve))
BRepAdaptor.Curve.bezier Ptr Curve
curve
    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 (Handle BezierCurve) -> Double -> Double -> IO ()
Geom.BezierCurve.segment Ptr (Handle BezierCurve)
bezier Double
firstParam Double
lastParam 
    Ptr Edge -> Ptr (Handle BezierCurve) -> Acquire [PathCommand]
bezierCurveToPathCommand Ptr Edge
edge Ptr (Handle BezierCurve)
bezier

convertBSpline :: Ptr TopoDS.Edge -> Ptr (Handle Geom.BSplineCurve) -> Acquire [Svg.PathCommand]
convertBSpline :: Ptr Edge -> Ptr (Handle BSplineCurve) -> Acquire [PathCommand]
convertBSpline Ptr Edge
edge Ptr (Handle BSplineCurve)
someBSpline = do
    Ptr BSplineCurveToBezierCurve
converter <- Ptr (Handle BSplineCurve)
-> Acquire (Ptr BSplineCurveToBezierCurve)
GeomConvert.BSplineCurveToBezierCurve.fromHandle Ptr (Handle BSplineCurve)
someBSpline -- ParametersAndTolerance someBSpline firstParameter lastParameter 1e-3
    Int
nbArcs <- 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 BSplineCurveToBezierCurve -> IO Int
GeomConvert.BSplineCurveToBezierCurve.nbArcs Ptr BSplineCurveToBezierCurve
converter
    [[PathCommand]] -> [PathCommand]
forall a. Monoid a => [a] -> a
mconcat ([[PathCommand]] -> [PathCommand])
-> Acquire [[PathCommand]] -> Acquire [PathCommand]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Acquire [PathCommand]) -> [Int] -> Acquire [[PathCommand]]
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 Edge -> Ptr (Handle BezierCurve) -> Acquire [PathCommand]
bezierCurveToPathCommand Ptr Edge
edge (Ptr (Handle BezierCurve) -> Acquire [PathCommand])
-> (Int -> Acquire (Ptr (Handle BezierCurve)))
-> Int
-> Acquire [PathCommand]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Ptr BSplineCurveToBezierCurve
-> Int -> Acquire (Ptr (Handle BezierCurve))
GeomConvert.BSplineCurveToBezierCurve.arc Ptr BSplineCurveToBezierCurve
converter) [Int
1 .. Int
nbArcs]

approximateCurveToPathCommand :: Ptr TopoDS.Edge -> Acquire [Svg.PathCommand]
approximateCurveToPathCommand :: Ptr Edge -> Acquire [PathCommand]
approximateCurveToPathCommand Ptr Edge
edge = do
    Ptr (Handle Curve)
gc <- Ptr Edge -> Acquire (Ptr (Handle Curve))
BRep.Tool.curve Ptr Edge
edge
    Double
firstParam <- IO Double -> Acquire Double
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> Acquire Double) -> IO Double -> Acquire Double
forall a b. (a -> b) -> a -> b
$ Ptr Edge -> IO Double
BRep.Tool.curveParamFirst Ptr Edge
edge
    Double
lastParam <- IO Double -> Acquire Double
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> Acquire Double) -> IO Double -> Acquire Double
forall a b. (a -> b) -> a -> b
$ Ptr Edge -> IO Double
BRep.Tool.curveParamLast Ptr Edge
edge
    Ptr Curve
scc <- Acquire (Ptr Curve)
ShapeConstruct.Curve.new
    Ptr (Handle BSplineCurve)
curve <- Ptr Curve
-> Ptr (Handle Curve)
-> Double
-> Double
-> Double
-> Acquire (Ptr (Handle BSplineCurve))
ShapeConstruct.Curve.convertToBSpline Ptr Curve
scc Ptr (Handle Curve)
gc Double
firstParam Double
lastParam Double
1e-3
    Ptr Edge -> Ptr (Handle BSplineCurve) -> Acquire [PathCommand]
preciseBSplineToPathCommand Ptr Edge
edge Ptr (Handle BSplineCurve)
curve 

preciseBSplineToPathCommand :: Ptr TopoDS.Edge -> Ptr (Handle Geom.BSplineCurve)-> Acquire [Svg.PathCommand]
preciseBSplineToPathCommand :: Ptr Edge -> Ptr (Handle BSplineCurve) -> Acquire [PathCommand]
preciseBSplineToPathCommand Ptr Edge
edge Ptr (Handle BSplineCurve)
curve = do
    Int
nbPoles <- 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 BSplineCurve) -> IO Int
Geom.BSplineCurve.nbPoles Ptr (Handle BSplineCurve)
curve
    Bool
isRational <- 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 (Handle BSplineCurve) -> IO Bool
Geom.BSplineCurve.isRational Ptr (Handle BSplineCurve)
curve
    let needsApproximating :: Bool
needsApproximating = (Int
nbPoles Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4 Bool -> Bool -> Bool
|| Bool
isRational)
    if Bool -> Bool
not Bool
needsApproximating
        then Ptr Edge -> Ptr (Handle BSplineCurve) -> Acquire [PathCommand]
convertBSpline Ptr Edge
edge Ptr (Handle BSplineCurve)
curve
        else do
            Ptr ApproxCurve
approximator <- Ptr (Handle Curve)
-> Double -> Shape -> Int -> Int -> Acquire (Ptr ApproxCurve)
GeomConvert.ApproxCurve.fromCurveToleranceOrderSegmentsAndDegree (Ptr (Handle BSplineCurve) -> Ptr (Handle Curve)
forall a b. SubTypeOf a b => Ptr b -> Ptr a
upcast Ptr (Handle BSplineCurve)
curve) Double
1e-3 Shape
GeomAbs.Shape.C0 Int
100 Int
3
            Bool
done <- 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 ApproxCurve -> IO Bool
GeomConvert.ApproxCurve.isDone Ptr ApproxCurve
approximator
            if Bool
done
                then do
                    Ptr (Handle BSplineCurve)
newCurve <- Ptr ApproxCurve -> Acquire (Ptr (Handle BSplineCurve))
GeomConvert.ApproxCurve.curve Ptr ApproxCurve
approximator
                    Ptr Edge -> Ptr (Handle BSplineCurve) -> Acquire [PathCommand]
convertBSpline Ptr Edge
edge Ptr (Handle BSplineCurve)
newCurve
                else 
                    IO [PathCommand] -> Acquire [PathCommand]
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [PathCommand] -> Acquire [PathCommand])
-> IO [PathCommand] -> Acquire [PathCommand]
forall a b. (a -> b) -> a -> b
$ Ptr Edge -> IO [PathCommand]
discretizedEdgePathCommand Ptr Edge
edge
    
discretizedEdgePathCommand :: Ptr TopoDS.Edge -> IO [Svg.PathCommand]
discretizedEdgePathCommand :: Ptr Edge -> IO [PathCommand]
discretizedEdgePathCommand Ptr Edge
edge = do
    [V3 Double]
ps <- (Integer -> IO (V3 Double)) -> [Integer] -> IO [V3 Double]
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 Edge -> Double -> IO (V3 Double)
Internal.Edges.edgeValue Ptr Edge
edge (Double -> IO (V3 Double))
-> (Integer -> Double) -> Integer -> IO (V3 Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
10) (Double -> Double) -> (Integer -> Double) -> Integer -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Integer
1..(Integer
10::Integer)]
    [PathCommand] -> IO [PathCommand]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PathCommand] -> IO [PathCommand])
-> ([RPoint] -> [PathCommand]) -> [RPoint] -> IO [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathCommand -> [PathCommand]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathCommand -> [PathCommand])
-> ([RPoint] -> PathCommand) -> [RPoint] -> [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        Origin -> [RPoint] -> PathCommand
Svg.LineTo Origin
Svg.OriginAbsolute ([RPoint] -> IO [PathCommand]) -> [RPoint] -> IO [PathCommand]
forall a b. (a -> b) -> a -> b
$ (V3 Double -> Getting RPoint (V3 Double) RPoint -> RPoint
forall s a. s -> Getting a s a -> a
^. Getting RPoint (V3 Double) RPoint
forall a. Lens' (V3 a) (V2 a)
forall (t :: * -> *) a. R2 t => Lens' (t a) (V2 a)
_xy) (V3 Double -> RPoint) -> [V3 Double] -> [RPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [V3 Double]
ps

edgeToPathCommand :: Maybe (V2 Double) -> Ptr TopoDS.Edge -> (Maybe (V2 Double), [Svg.PathCommand])
edgeToPathCommand :: Maybe RPoint -> Ptr Edge -> (Maybe RPoint, [PathCommand])
edgeToPathCommand Maybe RPoint
curPos Ptr Edge
edge = Acquire (Maybe RPoint, [PathCommand])
-> (Maybe RPoint, [PathCommand])
forall a. Acquire a -> a
Internal.Finalizers.unsafeFromAcquire (Acquire (Maybe RPoint, [PathCommand])
 -> (Maybe RPoint, [PathCommand]))
-> Acquire (Maybe RPoint, [PathCommand])
-> (Maybe RPoint, [PathCommand])
forall a b. (a -> b) -> a -> b
$ do
    RPoint
startPos <- IO RPoint -> Acquire RPoint
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RPoint -> Acquire RPoint) -> IO RPoint -> Acquire RPoint
forall a b. (a -> b) -> a -> b
$ (V3 Double -> Getting RPoint (V3 Double) RPoint -> RPoint
forall s a. s -> Getting a s a -> a
^. Getting RPoint (V3 Double) RPoint
forall a. Lens' (V3 a) (V2 a)
forall (t :: * -> *) a. R2 t => Lens' (t a) (V2 a)
_xy) (V3 Double -> RPoint) -> IO (V3 Double) -> IO RPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Edge -> Double -> IO (V3 Double)
Internal.Edges.edgeValue Ptr Edge
edge Double
0
    RPoint
endPos <- IO RPoint -> Acquire RPoint
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RPoint -> Acquire RPoint) -> IO RPoint -> Acquire RPoint
forall a b. (a -> b) -> a -> b
$ (V3 Double -> Getting RPoint (V3 Double) RPoint -> RPoint
forall s a. s -> Getting a s a -> a
^. Getting RPoint (V3 Double) RPoint
forall a. Lens' (V3 a) (V2 a)
forall (t :: * -> *) a. R2 t => Lens' (t a) (V2 a)
_xy) (V3 Double -> RPoint) -> IO (V3 Double) -> IO RPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Edge -> Double -> IO (V3 Double)
Internal.Edges.edgeValue Ptr Edge
edge Double
1
    let hasntMoved :: Maybe Bool
hasntMoved = RPoint -> Bool
forall a. Epsilon a => a -> Bool
nearZero (RPoint -> Bool) -> (RPoint -> RPoint) -> RPoint -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RPoint
startPos RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
-) (RPoint -> Bool) -> Maybe RPoint -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RPoint
curPos
    let addMoveCommand :: [PathCommand] -> [PathCommand]
addMoveCommand = 
            case Maybe Bool
hasntMoved of 
                Just Bool
True -> [PathCommand] -> [PathCommand]
forall a. a -> a
id
                Maybe Bool
_ -> ((Origin -> [RPoint] -> PathCommand
Svg.MoveTo Origin
Svg.OriginAbsolute ([RPoint] -> PathCommand)
-> (RPoint -> [RPoint]) -> RPoint -> PathCommand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPoint -> [RPoint]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RPoint -> PathCommand) -> RPoint -> PathCommand
forall a b. (a -> b) -> a -> b
$ RPoint
startPos) PathCommand -> [PathCommand] -> [PathCommand]
forall a. a -> [a] -> [a]
:)
    Ptr Curve
adaptor <- Ptr Edge -> Acquire (Ptr Curve)
BRepAdaptor.Curve.fromEdge Ptr Edge
edge
    CurveType
curveType <- IO CurveType -> Acquire CurveType
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CurveType -> Acquire CurveType)
-> IO CurveType -> Acquire CurveType
forall a b. (a -> b) -> a -> b
$ Ptr Curve -> IO CurveType
BRepAdaptor.Curve.curveType Ptr Curve
adaptor
    [PathCommand]
thisSegment <-
        case CurveType
curveType of 
            CurveType
GeomAbs.CurveType.Line -> IO [PathCommand] -> Acquire [PathCommand]
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [PathCommand] -> Acquire [PathCommand])
-> IO [PathCommand] -> Acquire [PathCommand]
forall a b. (a -> b) -> a -> b
$ Ptr Edge -> IO [PathCommand]
lineToPathCommand Ptr Edge
edge
            CurveType
GeomAbs.CurveType.BezierCurve -> Ptr Edge -> Ptr Curve -> Acquire [PathCommand]
bezierToPathCommand Ptr Edge
edge Ptr Curve
adaptor
            -- GeomAbs.CurveType.BSplineCurve -> There's some argument for special casing this, but we don't need to
            CurveType
_ -> Ptr Edge -> Acquire [PathCommand]
approximateCurveToPathCommand Ptr Edge
edge
    (Maybe RPoint, [PathCommand])
-> Acquire (Maybe RPoint, [PathCommand])
forall a. a -> Acquire a
forall (m :: * -> *) a. Monad m => a -> m a
return (RPoint -> Maybe RPoint
forall a. a -> Maybe a
Just RPoint
endPos, [PathCommand] -> [PathCommand]
addMoveCommand [PathCommand]
thisSegment)

-- | Convert a `Waterfall.Path2D` into a list of `Svg.PathCommands`
path2DToPathCommands :: Waterfall.Path2D -> [Svg.PathCommand]
path2DToPathCommands :: Path2D -> [PathCommand]
path2DToPathCommands (Path2D RawPath
theRawPath) = case RawPath
theRawPath of  
    RawPath
Internal.Path.Common.EmptyRawPath -> []
    Internal.Path.Common.SinglePointRawPath V3 Double
_ -> []
    Internal.Path.Common.ComplexRawPath Ptr Wire
wire -> 
        Acquire [PathCommand] -> [PathCommand]
forall (t :: * -> *) a. Traversable t => Acquire (t a) -> t a
Internal.Finalizers.unsafeFromAcquireT (Acquire [PathCommand] -> [PathCommand])
-> Acquire [PathCommand] -> [PathCommand]
forall a b. (a -> b) -> a -> b
$
            [[PathCommand]] -> [PathCommand]
forall a. Monoid a => [a] -> a
mconcat 
                ([[PathCommand]] -> [PathCommand])
-> ([Ptr Edge] -> [[PathCommand]]) -> [Ptr Edge] -> [PathCommand]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe RPoint, [PathCommand]) -> [PathCommand])
-> [(Maybe RPoint, [PathCommand])] -> [[PathCommand]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe RPoint, [PathCommand]) -> [PathCommand]
forall a b. (a, b) -> b
snd
                ([(Maybe RPoint, [PathCommand])] -> [[PathCommand]])
-> ([Ptr Edge] -> [(Maybe RPoint, [PathCommand])])
-> [Ptr Edge]
-> [[PathCommand]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr Edge
 -> (Maybe RPoint, [PathCommand]) -> (Maybe RPoint, [PathCommand]))
-> (Maybe RPoint, [PathCommand])
-> [Ptr Edge]
-> [(Maybe RPoint, [PathCommand])]
forall a b. (a -> b -> b) -> b -> [a] -> [b]
scanr (((Maybe RPoint, [PathCommand])
 -> Ptr Edge -> (Maybe RPoint, [PathCommand]))
-> Ptr Edge
-> (Maybe RPoint, [PathCommand])
-> (Maybe RPoint, [PathCommand])
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe RPoint -> Ptr Edge -> (Maybe RPoint, [PathCommand])
edgeToPathCommand (Maybe RPoint -> Ptr Edge -> (Maybe RPoint, [PathCommand]))
-> ((Maybe RPoint, [PathCommand]) -> Maybe RPoint)
-> (Maybe RPoint, [PathCommand])
-> Ptr Edge
-> (Maybe RPoint, [PathCommand])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe RPoint, [PathCommand]) -> Maybe RPoint
forall a b. (a, b) -> a
fst)) (Maybe RPoint
forall a. Maybe a
Nothing, []) 
                ([Ptr Edge] -> [PathCommand])
-> Acquire [Ptr Edge] -> Acquire [PathCommand]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Wire -> Acquire [Ptr Edge]
Internal.Edges.wireEdges Ptr Wire
wire

-- | Convert a `Waterfall.Diagram` into an SVG document
-- 
-- The diagram paths have the classes "edge", "visible"/"hidden" and "sharp"/"outline"
diagramToSvg :: Waterfall.Diagram -> Svg.Document
diagramToSvg :: Diagram -> Document
diagramToSvg Diagram
diagram = 
    case Diagram -> Maybe (RPoint, RPoint)
Waterfall.diagramBoundingBox Diagram
diagram of 
        Maybe (RPoint, RPoint)
Nothing -> Maybe (Double, Double, Double, Double)
-> Maybe Number
-> Maybe Number
-> [Tree]
-> Map String Element
-> String
-> [CssRule]
-> String
-> Document
Svg.Document Maybe (Double, Double, Double, Double)
forall a. Maybe a
Nothing Maybe Number
forall a. Maybe a
Nothing Maybe Number
forall a. Maybe a
Nothing [] Map String Element
forall a. Monoid a => a
mempty String
forall a. Monoid a => a
mempty [CssRule]
forall a. Monoid a => a
mempty String
forall a. Monoid a => a
mempty
        Just (RPoint
lo, RPoint
hi) -> 
            let w :: Maybe Number
w = Number -> Maybe Number
forall a. a -> Maybe a
Just (Number -> Maybe Number)
-> (Double -> Number) -> Double -> Maybe Number
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Number
Svg.Num (Double -> Maybe Number) -> Double -> Maybe Number
forall a b. (a -> b) -> a -> b
$ (RPoint
hi RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
- RPoint
lo) RPoint -> Getting Double RPoint Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double RPoint Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
4
                h :: Maybe Number
h = Number -> Maybe Number
forall a. a -> Maybe a
Just (Number -> Maybe Number)
-> (Double -> Number) -> Double -> Maybe Number
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Number
Svg.Num (Double -> Maybe Number) -> Double -> Maybe Number
forall a b. (a -> b) -> a -> b
$ (RPoint
hi RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
- RPoint
lo) RPoint -> Getting Double RPoint Double -> Double
forall s a. s -> Getting a s a -> a
^. Getting Double RPoint Double
forall a. Lens' (V2 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
4
                d' :: Diagram
d' = RPoint -> Diagram -> Diagram
forall a. Transformable2D a => RPoint -> a -> a
Waterfall.translate2D (RPoint
2 RPoint -> RPoint -> RPoint
forall a. Num a => a -> a -> a
+ RPoint -> RPoint
forall a. Num a => a -> a
negate RPoint
lo) Diagram
diagram
                paths :: LineType -> Visibility -> [PathCommand]
paths LineType
lt Visibility
visibility =
                    Path2D -> [PathCommand]
path2DToPathCommands (Path2D -> [PathCommand]) -> [Path2D] -> [PathCommand]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                        LineType -> Visibility -> Diagram -> [Path2D]
Waterfall.diagramLines LineType
lt Visibility
visibility Diagram
d'
                styles :: [CssRule]
styles = 
                    [ [CssSelectorRule] -> [CssDeclaration] -> CssRule
Svg.Css.CssRule 
                        [[[CssDescriptor] -> CssSelector
Svg.Css.AllOf [Text -> CssDescriptor
Svg.Css.OfClass Text
"edge"]]]
                        [Text -> [[CssElement]] -> CssDeclaration
Svg.Css.CssDeclaration Text
"fill" [[Text -> CssElement
Svg.Css.CssIdent Text
"None"]]]
                    , [CssSelectorRule] -> [CssDeclaration] -> CssRule
Svg.Css.CssRule
                        [[[CssDescriptor] -> CssSelector
Svg.Css.AllOf [Text -> CssDescriptor
Svg.Css.OfClass Text
"edge", Text -> CssDescriptor
Svg.Css.OfClass Text
"visible"]]]
                        [Text -> [[CssElement]] -> CssDeclaration
Svg.Css.CssDeclaration Text
"stroke" [[PixelRGBA8 -> CssElement
Svg.Css.CssColor (PixelRGBA8 -> CssElement) -> PixelRGBA8 -> CssElement
forall a b. (a -> b) -> a -> b
$ Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
0 Pixel8
0 Pixel8
0 Pixel8
255]]]
                    , [CssSelectorRule] -> [CssDeclaration] -> CssRule
Svg.Css.CssRule
                        [[[CssDescriptor] -> CssSelector
Svg.Css.AllOf [Text -> CssDescriptor
Svg.Css.OfClass Text
"edge", Text -> CssDescriptor
Svg.Css.OfClass Text
"hidden"]]]
                        [Text -> [[CssElement]] -> CssDeclaration
Svg.Css.CssDeclaration Text
"stroke" [[PixelRGBA8 -> CssElement
Svg.Css.CssColor (PixelRGBA8 -> CssElement) -> PixelRGBA8 -> CssElement
forall a b. (a -> b) -> a -> b
$ Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
PixelRGBA8 Pixel8
200 Pixel8
200 Pixel8
255 Pixel8
255]]]
                    ]
                document :: Tree -> Document
document Tree
e = Maybe (Double, Double, Double, Double)
-> Maybe Number
-> Maybe Number
-> [Tree]
-> Map String Element
-> String
-> [CssRule]
-> String
-> Document
Svg.Document Maybe (Double, Double, Double, Double)
forall a. Maybe a
Nothing Maybe Number
w Maybe Number
h [Tree
e] Map String Element
forall a. Monoid a => a
mempty String
forall a. Monoid a => a
mempty [CssRule]
styles String
forall a. Monoid a => a
mempty
                drawAttrs :: [Text] -> b
drawAttrs [Text]
classes = b
forall a. Monoid a => a
mempty 
                    b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> b -> Identity b
forall a. HasDrawAttributes a => Lens' a [Text]
Lens' b [Text]
Svg.attrClass (([Text] -> Identity [Text]) -> b -> Identity b)
-> [Text] -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text]
classes
                pathOf :: LineType -> Visibility -> [Text] -> Tree
pathOf LineType
lt Visibility
visibility [Text]
classes = Path -> Tree
Svg.PathTree (Path -> Tree) -> Path -> Tree
forall a b. (a -> b) -> a -> b
$ DrawAttributes -> [PathCommand] -> Path
Svg.Path ([Text] -> DrawAttributes
forall {b}. (Monoid b, HasDrawAttributes b) => [Text] -> b
drawAttrs [Text]
classes) (LineType -> Visibility -> [PathCommand]
paths LineType
lt Visibility
visibility)
                group :: [Tree] -> Tree
group [Tree]
children = Group Tree -> Tree
Svg.GroupTree (Group Tree -> Tree) -> Group Tree -> Tree
forall a b. (a -> b) -> a -> b
$ DrawAttributes
-> [Tree]
-> Maybe (Double, Double, Double, Double)
-> PreserveAspectRatio
-> Group Tree
forall a.
DrawAttributes
-> [a]
-> Maybe (Double, Double, Double, Double)
-> PreserveAspectRatio
-> Group a
Svg.Group DrawAttributes
forall a. Monoid a => a
mempty [Tree]
children Maybe (Double, Double, Double, Double)
forall a. Maybe a
Nothing PreserveAspectRatio
forall a. WithDefaultSvg a => a
Svg.defaultSvg
            in Tree -> Document
document (Tree -> Document) -> ([Tree] -> Tree) -> [Tree] -> Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tree] -> Tree
group ([Tree] -> Document) -> [Tree] -> Document
forall a b. (a -> b) -> a -> b
$
                    [ LineType -> Visibility -> [Text] -> Tree
pathOf LineType
lineType Visibility
visibility [Text
"edge", Text
ltClass, Text
vClass]
                        | (Visibility
visibility, Text
vClass) <- [(Visibility
Waterfall.Hidden, Text
"hidden"), (Visibility
Waterfall.Visible, Text
"visible")]
                        , (LineType
lineType, Text
ltClass) <- [(LineType
Waterfall.SharpLine, Text
"sharp"), (LineType
Waterfall.OutLine, Text
"outline")]
                    ]
                    
-- | Write a `Waterfall.Diagram`, to an SVG file at the specified location 
writeDiagramSVG :: FilePath -> Waterfall.Diagram -> IO ()
writeDiagramSVG :: String -> Diagram -> IO ()
writeDiagramSVG String
path = String -> Document -> IO ()
Svg.saveXmlFile String
path (Document -> IO ()) -> (Diagram -> Document) -> Diagram -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Diagram -> Document
diagramToSvg