waterfall-cad 0.3.0.1 → 0.4.0.0

raw patch · 11 files changed

+225/−36 lines, 11 filesdep ~opencascade-hsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: opencascade-hs

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• src/Waterfall.hs +3/−0
• src/Waterfall/Internal/Edges.hs +82/−4
• src/Waterfall/Internal/Path.hs +15/−10
• src/Waterfall/Internal/ToOpenCascade.hs +24/−0
• src/Waterfall/Loft.hs +46/−0
• src/Waterfall/Path.hs +8/−0
• src/Waterfall/Path/Common.hs +17/−2
• src/Waterfall/TwoD/Internal/Path2D.hs +7/−10
• src/Waterfall/TwoD/Path2D.hs +11/−8
• waterfall-cad.cabal +4/−2

@@ -9,6 +9,14 @@  ## Unreleased +## 0.4.0.0++- Add `Waterfall.Loft` containing `loft` and `pointedLoft`+- Change the `Monoid` instance for `Path` and `Path2D`, so that in the expression `a <> b` a line is added between the end of `a` and the start of `b`, unless these points are coincident.+- Reverse the order in which Path.pathFrom adds path segments; required by the new Monoid behaviour.+- Add `Waterfall.Path.Common.reversePath`, reversing the direction of a `Path` or `Path2D`, along with monomorphised versions `reversePath3D` and `reversePath2D`+- Fix order of rotation of `Waterfall.TwoD.Path2D.repeatLooping`+ ## 0.3.0.1  ### Added

@@ -35,6 +35,8 @@ , module Waterfall.TwoD.Shape -- | Sweep a 2D `Shape` along a `Path`, constructing a `Solid`. , module Waterfall.Sweep+-- | Generate a [Loft](https://en.wikipedia.org/wiki/Loft_\(3D\)) between a sequence of `Path`s+, module Waterfall.Loft -- | Construct a `Solid` of revolution from a `Path2D`. , module Waterfall.Revolution -- | Transforms for data types that exist in Two Dimensional space, like `Shape` and `Path2D`.@@ -62,6 +64,7 @@ import Waterfall.Revolution import Waterfall.Solids import Waterfall.Sweep+import Waterfall.Loft import Waterfall.Transforms import Waterfall.TwoD.Transforms import Waterfall.TwoD.Path2D

@@ -1,20 +1,28 @@ module Waterfall.Internal.Edges ( edgeEndpoints , wireEndpoints+, allWireEndpoints , wireTangent+, reverseEdge+, reverseWire+, intersperseLines+, joinWires ) where  import qualified OpenCascade.TopoDS as TopoDS import qualified OpenCascade.BRep.Tool as BRep.Tool import qualified OpenCascade.Geom.Curve as Geom.Curve import qualified OpenCascade.BRepTools.WireExplorer as WireExplorer+import qualified OpenCascade.BRepBuilderAPI.MakeEdge as MakeEdge import Waterfall.Internal.FromOpenCascade (gpPntToV3, gpVecToV3) import Data.Acquire import Control.Monad.IO.Class (liftIO)-import Linear (V3 (..))+import Linear (V3 (..), distance) import Foreign.Ptr--+import qualified OpenCascade.BRepBuilderAPI.MakeWire as MakeWire+import Control.Monad (when)+import Waterfall.Internal.ToOpenCascade (v3ToPnt)+import Data.Foldable (traverse_)  edgeEndpoints :: Ptr TopoDS.Edge -> IO (V3 Double, V3 Double) edgeEndpoints edge = (`with` pure) $ do@@ -25,6 +33,18 @@     e <- (liftIO . gpPntToV3) =<< Geom.Curve.value curve p2     return (s, e) +allWireEndpoints :: Ptr TopoDS.Wire -> IO [(V3 Double, V3 Double)]+allWireEndpoints wire = with (WireExplorer.fromWire wire) $ \explorer -> do+    let runToEnd = do+            edge <- WireExplorer.current explorer+            points <- edgeEndpoints edge+            WireExplorer.next explorer+            more <- WireExplorer.more explorer+            if more +                then (points:) <$> runToEnd+                else pure [points]+    runToEnd+ wireEndpoints :: Ptr TopoDS.Wire -> IO (V3 Double, V3 Double) wireEndpoints wire = with (WireExplorer.fromWire wire) $ \explorer -> do     v1 <- WireExplorer.current explorer@@ -40,7 +60,6 @@     e <- runToEnd     return (s, e) - edgeTangent :: Ptr TopoDS.Edge -> IO (V3 Double) edgeTangent e = (`with` pure) $ do     curve <- BRep.Tool.curve e@@ -51,3 +70,62 @@ wireTangent wire = with (WireExplorer.fromWire wire) $ \explorer -> do     v1 <- WireExplorer.current explorer     edgeTangent v1++reverseEdge :: Ptr TopoDS.Edge -> Acquire (Ptr TopoDS.Edge)+reverseEdge e = do+    curve <- BRep.Tool.curve e +    firstP <- liftIO $ BRep.Tool.curveParamFirst e+    lastP <- liftIO $ BRep.Tool.curveParamLast e+    firstP' <- liftIO $ Geom.Curve.reversedParameter curve firstP+    lastP' <- liftIO $ Geom.Curve.reversedParameter curve lastP+    curve' <- Geom.Curve.reversed curve+    MakeEdge.fromCurveAndParameters curve' lastP' firstP' ++reverseWire :: Ptr TopoDS.Wire -> Acquire (Ptr TopoDS.Wire) +reverseWire wire = do+    explorer <- WireExplorer.fromWire wire+    makeWire <- MakeWire.new+    let runToEnd = do+            edge <- liftIO $ WireExplorer.current explorer+            edge' <- reverseEdge edge+            liftIO $ WireExplorer.next explorer+            more <- liftIO $ WireExplorer.more explorer+            when more runToEnd+            liftIO $ MakeWire.addEdge makeWire edge'+    runToEnd+    MakeWire.wire makeWire++line' :: V3 Double -> V3 Double -> Acquire (Ptr TopoDS.Wire)+line' s e = do+    builder <- MakeWire.new+    pt1 <- v3ToPnt s+    pt2 <- v3ToPnt e+    edge <- MakeEdge.fromPnts pt1 pt2+    liftIO $ MakeWire.addEdge builder edge+    MakeWire.wire builder+    +intersperseLines :: [Ptr TopoDS.Wire] -> Acquire [Ptr TopoDS.Wire]+intersperseLines [] = pure []+intersperseLines [x] = pure [x]+intersperseLines (a:b:xs) = do+    (_, ea) <- liftIO $ wireEndpoints a+    (sb, _) <- liftIO $ wireEndpoints b+    if distance ea sb < 1e-6+            then (a :) <$> intersperseLines (b:xs)+            else (a :) <$> ((:) <$> line' ea sb <*> intersperseLines (b:xs))++joinWires :: [Ptr TopoDS.Wire] -> Acquire (Ptr TopoDS.Wire)+joinWires wires = do+    builder <- MakeWire.new+    let addWire wire = do +            explorer <- WireExplorer.fromWire wire+            let runToEnd = do+                    edge <- liftIO $ WireExplorer.current explorer+                    liftIO $ MakeWire.addEdge builder edge+                    liftIO $ WireExplorer.next explorer+                    more <- liftIO $ WireExplorer.more explorer+                    when more runToEnd+            runToEnd+    traverse_ addWire $ wires+    MakeWire.wire builder+

@@ -3,32 +3,37 @@ module Waterfall.Internal.Path ( Path (..) , joinPaths+, allPathEndpoints ) where  import Data.List.NonEmpty (NonEmpty ())-import Data.Foldable (traverse_, toList)+import Data.Foldable (toList) import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire) -import Control.Monad ((<=<)) import Control.Monad.IO.Class (liftIO) import qualified OpenCascade.TopoDS as TopoDS-import qualified OpenCascade.BRepBuilderAPI.MakeWire as MakeWire import Foreign.Ptr+import Linear (V3 (..)) import Data.Semigroup (sconcat)-+import Waterfall.Internal.Edges (allWireEndpoints, intersperseLines, joinWires) -- | A Path in 3D Space  -- -- Under the hood, this is represented by an OpenCascade `TopoDS.Wire`. newtype Path = Path { rawPath :: Ptr TopoDS.Wire } +-- | Exposing this because I found it useful for debugging+allPathEndpoints :: Path -> [(V3 Double, V3 Double)]+allPathEndpoints (Path raw) = unsafeFromAcquire $ do+    wire <- toAcquire raw+    liftIO $ allWireEndpoints wire+     joinPaths :: [Path] -> Path joinPaths paths = Path . unsafeFromAcquire $ do-    builder <- MakeWire.new-    traverse_ (liftIO . MakeWire.addWire builder <=< toAcquire . rawPath) paths-    MakeWire.wire builder+    wires <- traverse (toAcquire . rawPath) paths+    joinWires =<< intersperseLines wires --- | The Semigroup for `Path` attempts to join two paths that share a common endpoint.------ Attempts to combine paths that do not share a common endpoint currently in an error case that is not currently handled gracefully.+-- | Joins `Path`s, @ a <> b @ connects the end point of @ b @ to the start of @ b @, if these points are not coincident, a line is created between them.+-- +-- Attempts to combine paths in ways that generate a non manifold path will produce an error case that is not currently handled gracefully. instance Semigroup Path where     sconcat :: NonEmpty Path -> Path     sconcat = joinPaths . toList

@@ -0,0 +1,24 @@+module Waterfall.Internal.ToOpenCascade+( v3ToVertex+, v3ToPnt+) where++import Linear (V3 (..))+import Data.Acquire (Acquire)+import Foreign.Ptr (Ptr)+import qualified OpenCascade.TopoDS as TopoDS+import qualified OpenCascade.GP as GP+import qualified OpenCascade.GP.Pnt as GP.Pnt+import qualified OpenCascade.BRepBuilderAPI.MakeVertex as MakeVertex+++v3ToPnt :: V3 Double -> Acquire (Ptr GP.Pnt)+v3ToPnt (V3 x y z) = GP.Pnt.new x y z++v3ToVertex :: V3 Double -> Acquire (Ptr TopoDS.Vertex)+v3ToVertex v = do+    pnt <- v3ToPnt v+    builder <- MakeVertex.fromPnt pnt+    MakeVertex.vertex builder++    

@@ -0,0 +1,46 @@+{-|+Module: Waterfall.Loft++[Loft](https://en.wikipedia.org/wiki/Loft_\(3D\)) is a method to create smooth 3D shapes. ++Analagous to the [lofting](https://en.wikipedia.org/wiki/Lofting) process in boat building. +A loft is defined by planar cross-sections of the desired shape at chosen locations. +These cross-sections are then interpolated to form a smooth 3d shape.+-}+module Waterfall.Loft+( pointedLoft+, loft+) where++import Linear (V3 (..))+import Waterfall.Internal.Path (Path, rawPath)+import Waterfall.Internal.Solid (Solid (..), solidFromAcquire)+import Waterfall.Internal.ToOpenCascade (v3ToVertex)+import qualified OpenCascade.BRepOffsetAPI.ThruSections as ThruSections+import qualified OpenCascade.BRepBuilderAPI.MakeShape as MakeShape+import OpenCascade.Inheritance (upcast)+import Control.Monad.IO.Class (liftIO)+import Control.Monad (forM_, (<=<))++-- | Form a Loft which may terminate at defined points.+--+-- If the start or end points are set to `Nothing` then one end of the loft will be the terminal cross-section.+-- Otherwise, the loft will interpolate to that point.+pointedLoft :: Double -- ^ The loft precision, this should be a small value, e.g. @ 1e-6 @ +    -> Maybe (V3 Double) -- ^ Optional start point for the loft+    -> [Path] -- ^ Series of cross-sections that the loft will pass through+    -> Maybe (V3 Double) -- ^ Optional end point for the loft+    -> Solid+pointedLoft precision start paths end = +    solidFromAcquire $ do+        thruSections <- ThruSections.new True False precision+        forM_ start ((liftIO . ThruSections.addVertex thruSections) <=< v3ToVertex)+        forM_ paths (liftIO . ThruSections.addWire thruSections . rawPath)+        forM_ end ((liftIO . ThruSections.addVertex thruSections) <=< v3ToVertex)+        MakeShape.shape (upcast thruSections)++-- | Form a loft between a series of cross-sections.+loft :: Double  -- ^ The loft precision, this should be a small value, e.g @ 1e-6 @+    -> [Path] -- ^ Series of cross-sections that the loft will pass through+    -> Solid+loft precision paths = pointedLoft precision Nothing paths Nothing

@@ -18,6 +18,8 @@ , pathFrom3D , pathFromTo3D , pathEndpoints3D+, closeLoop3D+, reversePath3D ) where  import Waterfall.Internal.Path (Path(..))@@ -83,4 +85,10 @@ pathEndpoints3D :: Path -> (V3 Double, V3 Double) pathEndpoints3D = pathEndpoints +-- | `closeLoop` with the type fixed to `Path`+closeLoop3D :: Path -> Path+closeLoop3D = closeLoop  +-- | `reversePath` with the type fixed to `Path`+reversePath3D :: Path -> Path+reversePath3D = reversePath

@@ -22,6 +22,8 @@ , pathFrom , pathFromTo , pathEndpoints+, closeLoop+, reversePath ) where import Data.Acquire import qualified OpenCascade.TopoDS as TopoDS@@ -43,7 +45,8 @@ import Linear (V3 (..), V2 (..), _xy) import qualified OpenCascade.GP.Pnt as GP.Pnt import Control.Lens ((^.))-import Waterfall.Internal.Edges (wireEndpoints)+import Waterfall.Internal.Edges (wireEndpoints, reverseWire)+import Control.Monad ((<=<))  -- | Class used to abstract over constructing `Path` and `Path2D`  -- @@ -164,7 +167,7 @@ pathFromTo commands start =      let go (pos, paths) cmd = second (:paths) (cmd pos)         (end, allPaths) = foldl' go (start, []) commands-     in (end, mconcat allPaths)+     in (end, mconcat . reverse $ allPaths)  -- | Returns the start and end of a `Path` pathEndpoints :: forall point path. (AnyPath point path) => path -> (point, point)@@ -172,6 +175,18 @@     wire <- toWire path     (s, e) <- liftIO $ wireEndpoints wire     return (v3ToPoint (Proxy :: Proxy path) s, v3ToPoint (Proxy :: Proxy path) e)+++-- | Given a path, return a new path with the endpoints joined by a straight line.+closeLoop :: (AnyPath point path, Monoid path, Eq point) => path -> path+closeLoop p = +    let (s, e) = pathEndpoints p+     in if s == e +            then p+            else p <> line e s++reversePath :: (AnyPath point path) => path -> path+reversePath = fromWire . (reverseWire <=< toWire)  instance AnyPath (V3 Double) Path where     fromWire :: Acquire (Ptr TopoDS.Wire) -> Path

@@ -3,14 +3,12 @@ , joinPaths ) where -import Data.Foldable (traverse_, toList)+import Data.Foldable (toList) import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)-import Control.Monad ((<=<))-import Control.Monad.IO.Class (liftIO) import qualified OpenCascade.TopoDS as TopoDS-import qualified OpenCascade.BRepBuilderAPI.MakeWire as MakeWire import Foreign.Ptr import Data.Semigroup (sconcat)+import Waterfall.Internal.Edges (intersperseLines, joinWires)  -- | A Path in 2D Space  --@@ -22,13 +20,12 @@  joinPaths :: [Path2D] -> Path2D joinPaths paths = Path2D . unsafeFromAcquire $ do-    builder <- MakeWire.new-    traverse_ (liftIO . MakeWire.addWire builder <=< toAcquire . rawPath) paths-    MakeWire.wire builder+    wires <- traverse (toAcquire . rawPath) paths+    joinWires =<< intersperseLines wires --- | The Semigroup for `Path2D` attempts to join two paths that share a common endpoint.------ Attempts to combine paths that do not share a common endpoint currently in an error case that is not currently handled gracefully.+-- | Joins `Path2D`s, @ a <> b @ connects the end point of @ b @ to the start of @ b @, if these points are not coincident, a line is created between them.+-- +-- Attempts to combine paths in ways that generate a non manifold path will produce an error case that is not currently handled gracefully. instance Semigroup Path2D where     sconcat = joinPaths . toList     a <> b = joinPaths [a, b] 

@@ -10,7 +10,6 @@ , arcTo , arcRelative , repeatLooping-, closeLoop -- $ reexports , line2D , lineTo2D@@ -24,6 +23,8 @@ , pathFrom2D , pathFromTo2D , pathEndpoints2D+, closeLoop2D+, reversePath2D ) where   import Waterfall.TwoD.Internal.Path2D (Path2D(..))@@ -85,14 +86,8 @@     (s, e) <- liftIO . Internal.Edges.wireEndpoints $ path     let a = unangle (e ^. _xy) - unangle (s ^. _xy)     let times :: Integer = abs . round $ pi * 2 / a -    toAcquire . rawPath . mconcat $ [rotate2D (negate (fromIntegral n) * a) p | n <- [0..times]]+    toAcquire . rawPath . mconcat $ [rotate2D (fromIntegral n * a) p | n <- [0..times]] --- | Given a path, return a new path with the endpoints joined by a straight line.-closeLoop :: Path2D -> Path2D-closeLoop p = Path2D . unsafeFromAcquire $ do-    path <- toAcquire . rawPath $ p-    (s, e) <- liftIO . Internal.Edges.wireEndpoints $ path-    toAcquire .rawPath . mconcat $ [p, line (e ^. _xy)  (s ^. _xy)]  -- $reexports --@@ -145,3 +140,11 @@ -- | `pathEndpoints`, with the type fixed to `Path2D`  pathEndpoints2D :: Path2D -> (V2 Double, V2 Double) pathEndpoints2D = pathEndpoints++-- | `closeLoop` with the type fixed to `Path2D`+closeLoop2D :: Path2D -> Path2D+closeLoop2D = closeLoop ++-- | `reversePath` with the type fixed to `Path2D`+reversePath2D :: Path2D -> Path2D+reversePath2D = reversePath

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           waterfall-cad-version:        0.3.0.1+version:        0.4.0.0 synopsis:       Declarative CAD/Solid Modeling Library description:    Please see the README on GitHub at <https://github.com/joe-warren/opencascade-hs#readme> category:       Graphics@@ -40,7 +40,9 @@       Waterfall.Internal.Path       Waterfall.Internal.Remesh       Waterfall.Internal.Solid+      Waterfall.Internal.ToOpenCascade       Waterfall.IO+      Waterfall.Loft       Waterfall.Offset       Waterfall.Path       Waterfall.Path.Common@@ -65,7 +67,7 @@     , lattices >=2.0 && <3     , lens ==5.*     , linear >=1.21 && <2-    , opencascade-hs >=0.3.0.1 && <0.4+    , opencascade-hs >=0.4.0.0 && <0.5     , primitive >=0.7 && <0.10     , resourcet >=1.2 && <1.4   default-language: Haskell2010