diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,11 @@ ## Unreleased +## 0.6.2.0 + +- Added `Waterfall.Path.Common.pathLength`, `Waterfall.Path.pathLength3D` and `Waterfall.TwoD.Path2D.pathLength2D` +- Added `Waterfall.Path.Common.takePathFraction`, `Waterfall.Path.takePathFraction3D` and `Waterfall.TwoD.Path2D.takePathFraction2D` + ## 0.6.1.0 ### Added diff --git a/src/Waterfall/Internal/Edges.hs b/src/Waterfall/Internal/Edges.hs --- a/src/Waterfall/Internal/Edges.hs +++ b/src/Waterfall/Internal/Edges.hs @@ -14,6 +14,8 @@ , joinWires , splitWires , edgeToWire +, wireLength +, truncateWire ) where import qualified OpenCascade.TopoDS as TopoDS @@ -28,6 +30,10 @@ import qualified OpenCascade.BRepLib as BRepLib import OpenCascade.GeomAbs.Shape as GeomAbs.Shape import Waterfall.Internal.FromOpenCascade (gpPntToV3, gpVecToV3) +import qualified OpenCascade.BRepAdaptor.Curve as BRepAdaptor.Curve +import qualified OpenCascade.GCPnts.AbscissaPoint as AbscissaPoint +import qualified OpenCascade.GProp.GProps as GProps +import qualified OpenCascade.BRepGProp as BRepGProp import Data.Acquire import Control.Monad.IO.Class (liftIO) import Linear (V3 (..), distance, normalize, nearZero) @@ -244,8 +250,45 @@ makeSegment buildEdgeCurve3D :: Ptr TopoDS.Edge -> Acquire (Ptr TopoDS.Edge) -buildEdgeCurve3D edge = do +buildEdgeCurve3D edge = do edge' <- (liftIO . unsafeDowncast) =<< TopoDS.Shape.copy (upcast edge) _ <- liftIO $ BRepLib.buildCurve3d edge' 1e-5 GeomAbs.Shape.C1 14 0 return edge' + +shapeLength :: Ptr TopoDS.Shape -> IO Double +shapeLength shape = (`with` pure) $ do + gProp <- GProps.new + liftIO $ BRepGProp.linearProperties shape gProp False False + liftIO $ GProps.mass gProp + +edgeLength :: Ptr TopoDS.Edge -> IO Double +edgeLength = shapeLength . upcast + +wireLength :: Ptr TopoDS.Wire -> IO Double +wireLength = shapeLength . upcast + +truncateWire :: Double -> Ptr TopoDS.Wire -> Acquire (Ptr TopoDS.Wire) +truncateWire targetLength wire = do + explorer <- WireExplorer.fromWire wire + builder <- MakeWire.new + let go remaining = do + more <- liftIO $ WireExplorer.more explorer + when (more && not (nearZero remaining)) $ do + edge <- liftIO $ WireExplorer.current explorer + len <- liftIO $ edgeLength edge + if len <= remaining + then do + liftIO $ MakeWire.addEdge builder edge + liftIO $ WireExplorer.next explorer + go (remaining - len) + else do + curve <- BRep.Tool.curve edge + firstP <- liftIO $ BRep.Tool.curveParamFirst edge + adaptor <- BRepAdaptor.Curve.fromEdge edge + absPnt <- AbscissaPoint.fromCurveAbscissaAndParam adaptor remaining firstP + cutParam <- liftIO $ AbscissaPoint.parameter absPnt + trimmedEdge <- MakeEdge.fromCurveAndParameters curve firstP cutParam + liftIO $ MakeWire.addEdge builder trimmedEdge + go targetLength + MakeWire.wire builder diff --git a/src/Waterfall/Path.hs b/src/Waterfall/Path.hs --- a/src/Waterfall/Path.hs +++ b/src/Waterfall/Path.hs @@ -22,6 +22,8 @@ , reversePath3D , splice3D , splitPath3D +, pathLength3D +, takePathFraction3D ) where import Waterfall.Internal.Path (Path(..)) @@ -102,3 +104,11 @@ -- | `splitPath` with the type fixed to `Path` splitPath3D :: Path -> [Path] splitPath3D = splitPath + +-- | `pathLength` with the type fixed to `Path` +pathLength3D :: Path -> Double +pathLength3D = pathLength + +-- | `takePathFraction` with the type fixed to `Path` +takePathFraction3D :: Double -> Path -> Path +takePathFraction3D = takePathFraction diff --git a/src/Waterfall/Path/Common.hs b/src/Waterfall/Path/Common.hs --- a/src/Waterfall/Path/Common.hs +++ b/src/Waterfall/Path/Common.hs @@ -26,6 +26,8 @@ , closeLoop , reversePath , splitPath +, pathLength +, takePathFraction ) where import Data.Acquire import qualified OpenCascade.TopoDS as TopoDS @@ -36,7 +38,7 @@ import Waterfall.TwoD.Internal.Path2D (Path2D (..)) import Waterfall.Internal.Finalizers (unsafeFromAcquire, toAcquire, unsafeFromAcquireT) import Waterfall.Internal.FromOpenCascade (gpPntToV3) -import Waterfall.Internal.Edges (wireEndpoints, reverseWire, splitWires) +import Waterfall.Internal.Edges (wireEndpoints, reverseWire, splitWires, wireLength, truncateWire) import Control.Arrow (second) import Data.Foldable (foldl') import qualified OpenCascade.BRepBuilderAPI.MakeWire as MakeWire @@ -244,12 +246,40 @@ ComplexRawPath r -> fromWire . reverseWire $ r _ -> p --- | Break a path appart at any "non smooth" point +-- | Break a path apart at any "non smooth" point splitPath :: (AnyPath point path) => path -> [path] splitPath p = case deconstructPath p of ComplexRawPath r -> fmap (reconstructPath . ComplexRawPath) . unsafeFromAcquireT . splitWires $ r _ -> [p] + +-- | Measure a path +pathLength :: AnyPath point path => path -> Double +pathLength p = + case deconstructPath p of + ComplexRawPath r -> unsafeFromAcquire $ liftIO . wireLength =<< toAcquire r + _ -> 0 + +-- | Truncate a path to a fraction of its total length. +-- +-- The fraction is clamped to the range [0, 1]. +-- A value of 0 (or less) returns a single point at the start of the path, +-- a value of 1 (or greater) returns the original path. +takePathFraction :: forall point path. AnyPath point path => Double -> path -> path +takePathFraction fraction p + | fraction >= 1 = p + | fraction <= 0 = + case pathEndpoints p of + Just (s, _) -> reconstructPath . SinglePointRawPath $ pointToV3 (Proxy :: Proxy path) s + Nothing -> p + | otherwise = + case deconstructPath p of + ComplexRawPath r -> fromWire $ do + wire <- toAcquire r + totalLength <- liftIO $ wireLength wire + let targetLength = fraction * totalLength + truncateWire targetLength wire + _ -> p instance AnyPath (V3 Double) Path where reconstructPath :: RawPath -> Path diff --git a/src/Waterfall/TwoD/Path2D.hs b/src/Waterfall/TwoD/Path2D.hs --- a/src/Waterfall/TwoD/Path2D.hs +++ b/src/Waterfall/TwoD/Path2D.hs @@ -27,7 +27,9 @@ , reversePath2D , splice2D , splitPath2D -) where +, pathLength2D +, takePathFraction2D +) where import Waterfall.TwoD.Internal.Path2D (Path2D(..)) import Waterfall.TwoD.Transforms (rotate2D) @@ -159,3 +161,11 @@ -- | `splitPath` with the type fixed to `Path2D` splitPath2D :: Path2D -> [Path2D] splitPath2D = splitPath + +-- | `pathLength` with the type fixed to `Path` +pathLength2D :: Path2D -> Double +pathLength2D = pathLength + +-- | `takePathFraction` with the type fixed to `Path2D` +takePathFraction2D :: Double -> Path2D -> Path2D +takePathFraction2D = takePathFraction diff --git a/waterfall-cad.cabal b/waterfall-cad.cabal --- a/waterfall-cad.cabal +++ b/waterfall-cad.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: waterfall-cad -version: 0.6.1.0 +version: 0.6.2.0 synopsis: Declarative CAD/Solid Modeling Library description: Please see the README on GitHub at category: Graphics @@ -71,7 +71,7 @@ , lattices >=2.0 && <3 , lens ==5.* , linear >=1.21 && <2 - , opencascade-hs >=0.6.1.0 && <0.7 + , opencascade-hs >=0.6.2.0 && <0.7 , primitive >=0.7 && <0.10 , resourcet >=1.2 && <1.4 default-language: Haskell2010