waterfall-cad 0.4.0.0 → 0.5.0.0

raw patch · 21 files changed

+843/−243 lines, 21 filesdep ~opencascade-hsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: opencascade-hs

API changes (from Hackage documentation)

Files

• CHANGELOG.md +23/−0
• src/Waterfall.hs +3/−0
• src/Waterfall/Diagram.hs +121/−0
• src/Waterfall/Internal/Diagram.hs +17/−0
• src/Waterfall/Internal/Edges.hs +127/−7
• src/Waterfall/Internal/Finalizers.hs +22/−10
• src/Waterfall/Internal/Path.hs +10/−30
• src/Waterfall/Internal/Path/Common.hs +83/−0
• src/Waterfall/Internal/ToOpenCascade.hs +5/−0
• src/Waterfall/Loft.hs +21/−11
• src/Waterfall/Offset.hs +26/−8
• src/Waterfall/Path.hs +11/−1
• src/Waterfall/Path/Common.hs +130/−67
• src/Waterfall/Revolution.hs +12/−8
• src/Waterfall/Sweep.hs +6/−3
• src/Waterfall/Transforms.hs +72/−28
• src/Waterfall/TwoD/Internal/Path2D.hs +6/−24
• src/Waterfall/TwoD/Path2D.hs +22/−11
• src/Waterfall/TwoD/Shape.hs +22/−5
• src/Waterfall/TwoD/Transforms.hs +98/−27
• waterfall-cad.cabal +6/−3

@@ -9,6 +9,29 @@  ## Unreleased +### Added++- Add `splice`/`splice2D`/`splice3D` functions+- Add `splitPath`/`splitPath3D`/`splitPath2D` functions+- Add Epsilon constraint to `closeLoop` fixing behaviour when endpoints are _very close_ together +- Add `matTransform` and `matTransform2D` methods to the `Transformable` and `Transformable2D` typeclasses, respectively+- Add `shapePaths` to `Waterfall.TwoD.Shape`++### Changed++- Most functions in `Waterfall.Path.Common` now have an `Epsilon` constraint+- `pathEndpoints`/`pathEndpoints3D`/`pathEndpoints2D` now returns a `Maybe` (in case of an empty path)+- `offset` now no longer takes a tolerance+    - `offsetWithTolerance` is available if this is required+- `pointedLoft` and `loft` now no longer takes a precision argument+    - `pointedLoftWithPrecision` is available if this is required+- Rename `fromPath` to `makeShape` as I think this will result in more readable code++### Fixed++- fixed behaviour when scaling with a unit vector (no scaling)+- fixed `Path`/`Path2D` representation, so that the `Monoid` instance `mempty` value no longer generates crashes+ ## 0.4.0.0  - Add `Waterfall.Loft` containing `loft` and `pointedLoft`

@@ -50,12 +50,15 @@ -- This module defines functions that can be used with "Waterfall.Path" or "Waterfall.TwoD.Path2D". -- Those modules both export monomorphized variants of the functions defined in this module. , module Waterfall.Path.Common+-- | Generate 2D `Diagram`s from 3D `Shape`s+, module Waterfall.Diagram )where  import Waterfall.Booleans import Waterfall.Booleans.Operators import Waterfall.BoundingBox.AxisAligned import Waterfall.BoundingBox.Oriented+import Waterfall.Diagram import Waterfall.Fillet import Waterfall.IO import Waterfall.Offset

@@ -0,0 +1,121 @@+{-# LANGUAGE DerivingVia #-}+module Waterfall.Diagram+( Diagram+, LineType (..)+, Visibility (..)+, solidDiagram+, pathDiagram+, diagramLines+, diagramBoundingBox+) where++import Linear.V3 (V3)+import Linear.V2 (V2)+import Linear (_xy)+import Control.Lens ((^.))+import Waterfall.Internal.Solid (Solid (), acquireSolid)+import qualified OpenCascade.HLRBRep.TypeOfResultingEdge as HLRBRep+import qualified OpenCascade.HLRBRep.Algo as HLRBRep.Algo+import qualified OpenCascade.HLRAlgo.Projector as HLRAlgo.Projector+import qualified OpenCascade.HLRBRep.HLRToShape as HLRBRep.HLRToShape+import qualified OpenCascade.GP as GP+import qualified OpenCascade.GP.Ax2 as GP.Ax2+import qualified OpenCascade.Bnd.Box as Bnd.Box+import qualified OpenCascade.BRepBndLib as BRepBndLib+import Waterfall.Internal.ToOpenCascade (v3ToDir)+import Waterfall.TwoD.Internal.Path2D (Path2D (..))+import Control.Monad.IO.Class (liftIO)+import Waterfall.Internal.Finalizers (unsafeFromAcquire, unsafeFromAcquireT)+import Waterfall.Internal.Edges (allEdges, buildEdgeCurve3D, edgeToWire)+import Waterfall.Internal.Path.Common (RawPath (..))+import Waterfall.Internal.Diagram (RawDiagram (..))+import Waterfall.TwoD.Transforms (Transformable2D)+import Waterfall.Internal.FromOpenCascade (gpPntToV3)+import OpenCascade.Inheritance (upcast)+import Control.Monad (forM_)++-- | "Diagram" of a "Waterfall" part+--+-- This is similar to a collection of `Path2D`+-- indexed by `LineType` and `Visibility`+newtype Diagram = Diagram { rawDiagram :: RawDiagram }+    deriving (Semigroup, Monoid, Transformable2D) via RawDiagram++-- | Categorize the lines in a diagram+data LineType = +    -- | Represents lines at the edge of objects, the "silhouette" +    -- +    -- Does not include those parts of the silhouette that are also sharp+    OutLine +    -- | Sharp edges, parts of an object with C0 Continuity+    | SharpLine+    | RawLine HLRBRep.TypeOfResultingEdge+    deriving (Eq, Ord, Show)++lineTypeToOpenCascade :: LineType -> HLRBRep.TypeOfResultingEdge+lineTypeToOpenCascade OutLine = HLRBRep.OutLine+lineTypeToOpenCascade SharpLine = HLRBRep.Sharp+lineTypeToOpenCascade (RawLine lt) = lt++-- | Whether an edge is visible in a given projection, or not+data Visibility = Visible | Hidden deriving (Eq, Ord, Show)++-- | Produce a diagram of a `Solid`+-- +-- Uses an orthographic projection, viewed from the provided direction+solidDiagram :: V3 Double -> Solid -> Diagram+solidDiagram projectionDirection solid = Diagram . RawDiagram . unsafeFromAcquire $ do+    s' <- acquireSolid solid+    algo <- HLRBRep.Algo.new+    liftIO $ HLRBRep.Algo.add algo s'+    o <- GP.origin+    d <- v3ToDir projectionDirection+    projector <- HLRAlgo.Projector.fromAx2 =<< GP.Ax2.newAutoX o d+    liftIO $ do +        HLRBRep.Algo.projector algo projector+        HLRBRep.Algo.update algo+        HLRBRep.Algo.hide algo++    extractor <- HLRBRep.HLRToShape.fromAlgo algo++    return $ \lt v is3D -> do+        compoundOfEdges <- HLRBRep.HLRToShape.compoundOfEdges extractor lt v is3D+        rawEdges <- allEdges compoundOfEdges+        traverse buildEdgeCurve3D rawEdges++-- | Produce a `Diagram` from a `Path2D`+-- +-- @ diagramLines lt v . pathDiagram lt v = pure @+pathDiagram :: LineType -> Visibility -> Path2D -> Diagram+pathDiagram lt v (Path2D rawpath) =+    Diagram . RawDiagram $ \lt' v' _ -> +        if lineTypeToOpenCascade lt == lt' && (v == Visible) == v' +            then case rawpath of +                    (ComplexRawPath wire) -> allEdges (upcast wire)+                    _ -> pure []+            else pure []++-- | Access the lines in a `Diagram` as `Path2D`+diagramLines :: LineType -> Visibility -> Diagram -> [Path2D]+diagramLines lt v d = unsafeFromAcquireT $ do +    edges <- runDiagram (rawDiagram d) (lineTypeToOpenCascade lt) (v == Visible) False +    wires <- traverse edgeToWire edges+    return $ (Path2D . ComplexRawPath) <$> wires++-- | Compute the Axis Aligned Bounding Box of a `Diagram`+-- +-- Returns Nothing if the `Diagram` does not contain lines that are `OutLine` or `Sharp`+diagramBoundingBox :: Diagram -> Maybe (V2 Double, V2 Double)+diagramBoundingBox d = unsafeFromAcquire $ do+    outline <- runDiagram (rawDiagram d) HLRBRep.OutLine True False+    sharpLine <- runDiagram (rawDiagram d) HLRBRep.Sharp True False+    let allLines = outline <> sharpLine+    if null allLines+        then pure Nothing+        else do+            theBox <- Bnd.Box.new+            forM_ allLines $ \s -> (liftIO $ BRepBndLib.addOptimal (upcast s) theBox True False)+            p1 <- liftIO . gpPntToV3 =<< Bnd.Box.cornerMin theBox+            p2 <- liftIO . gpPntToV3 =<< Bnd.Box.cornerMax theBox+            return $ Just (p1 ^. _xy, p2 ^. _xy)+

@@ -0,0 +1,17 @@+{-# OPTIONS_HADDOCK not-home #-}+module Waterfall.Internal.Diagram +( RawDiagram (..)+) where++import qualified OpenCascade.TopoDS as TopoDS+import Data.Acquire (Acquire)+import Foreign.Ptr (Ptr)+import qualified OpenCascade.HLRBRep.TypeOfResultingEdge as HLRBRep++newtype RawDiagram = RawDiagram { runDiagram :: HLRBRep.TypeOfResultingEdge -> Bool -> Bool -> Acquire [Ptr TopoDS.Edge] }++instance Semigroup RawDiagram where+    a <> b = RawDiagram $ \lt v is3D -> (<>) <$> runDiagram a lt v is3D <*> runDiagram b lt v is3D++instance Monoid RawDiagram where+    mempty = RawDiagram $ \_ _ _ -> pure []

@@ -1,28 +1,42 @@ module Waterfall.Internal.Edges ( edgeEndpoints+, edgeValue , wireEndpoints , allWireEndpoints-, wireTangent+, allWires+, allEdges+, wireEdges+, wireTangentStart+, buildEdgeCurve3D , reverseEdge , reverseWire , intersperseLines , joinWires+, splitWires+, edgeToWire ) where  import qualified OpenCascade.TopoDS as TopoDS+import qualified OpenCascade.TopoDS.Shape as TopoDS.Shape 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.TopExp.Explorer as Explorer +import qualified OpenCascade.TopAbs.ShapeEnum as ShapeEnum+import qualified OpenCascade.TopTools.ShapeMapHasher as TopTools.ShapeMapHasher import qualified OpenCascade.BRepBuilderAPI.MakeEdge as MakeEdge+import qualified OpenCascade.BRepLib as BRepLib+import OpenCascade.GeomAbs.Shape as GeomAbs.Shape import Waterfall.Internal.FromOpenCascade (gpPntToV3, gpVecToV3) import Data.Acquire import Control.Monad.IO.Class (liftIO)-import Linear (V3 (..), distance)+import Linear (V3 (..), distance, normalize, nearZero) import Foreign.Ptr import qualified OpenCascade.BRepBuilderAPI.MakeWire as MakeWire import Control.Monad (when) import Waterfall.Internal.ToOpenCascade (v3ToPnt) import Data.Foldable (traverse_)+import OpenCascade.Inheritance (upcast, unsafeDowncast)  edgeEndpoints :: Ptr TopoDS.Edge -> IO (V3 Double, V3 Double) edgeEndpoints edge = (`with` pure) $ do@@ -33,6 +47,14 @@     e <- (liftIO . gpPntToV3) =<< Geom.Curve.value curve p2     return (s, e) +edgeValue :: Ptr TopoDS.Edge -> Double -> IO (V3 Double)+edgeValue edge v = (`with` pure) $ do+    curve <- BRep.Tool.curve edge+    p1 <- liftIO . BRep.Tool.curveParamFirst $ edge+    p2 <- liftIO . BRep.Tool.curveParamLast $ edge+    let p' = v * p1 + (1-v) * p2+    (liftIO . gpPntToV3) =<< Geom.Curve.value curve p'+ allWireEndpoints :: Ptr TopoDS.Wire -> IO [(V3 Double, V3 Double)] allWireEndpoints wire = with (WireExplorer.fromWire wire) $ \explorer -> do     let runToEnd = do@@ -45,6 +67,48 @@                 else pure [points]     runToEnd +allSubShapes :: ShapeEnum.ShapeEnum -> Ptr TopoDS.Shape -> Acquire [Ptr TopoDS.Shape]+allSubShapes t s = do +    explorer <- Explorer.new s t+    let go visited = do+            isMore <- liftIO $ Explorer.more explorer+            if isMore +                then do+                    v <- liftIO $ Explorer.value explorer+                    hash <- liftIO $ TopTools.ShapeMapHasher.hash v+                    let add = if hash `elem` visited then id else (v:) +                    liftIO $ Explorer.next explorer+                    add <$> go visited+                else return []+    go []++    +allSubShapesWithCopy :: ShapeEnum.ShapeEnum -> Ptr TopoDS.Shape -> Acquire [Ptr TopoDS.Shape]+allSubShapesWithCopy t s = do +    explorer <- Explorer.new s t+    let go visited = do+            isMore <- liftIO $ Explorer.more explorer+            if isMore +                then do+                    v <- liftIO $ Explorer.value explorer+                    hash <- liftIO $ TopTools.ShapeMapHasher.hash v+                    add <- if hash `elem` visited +                        then pure id +                        else do+                            v' <- TopoDS.Shape.copy v+                            return (v':) +                    liftIO $ Explorer.next explorer+                    add <$> go visited+                else return []+    go []+++allEdges :: Ptr TopoDS.Shape -> Acquire [Ptr TopoDS.Edge]+allEdges s = traverse (liftIO . unsafeDowncast) =<< allSubShapesWithCopy ShapeEnum.Edge s ++allWires :: Ptr TopoDS.Shape -> Acquire [Ptr TopoDS.Wire]+allWires s = traverse (liftIO . unsafeDowncast) =<< allSubShapes ShapeEnum.Wire s +     wireEndpoints :: Ptr TopoDS.Wire -> IO (V3 Double, V3 Double) wireEndpoints wire = with (WireExplorer.fromWire wire) $ \explorer -> do     v1 <- WireExplorer.current explorer@@ -60,16 +124,22 @@     e <- runToEnd     return (s, e) -edgeTangent :: Ptr TopoDS.Edge -> IO (V3 Double)-edgeTangent e = (`with` pure) $ do+edgeTangentStart :: Ptr TopoDS.Edge -> IO (V3 Double)+edgeTangentStart e = (`with` pure) $ do     curve <- BRep.Tool.curve e     p1 <- liftIO . BRep.Tool.curveParamFirst $ e     liftIO . gpVecToV3 =<< Geom.Curve.dn curve p1 1 -wireTangent :: Ptr TopoDS.Wire -> IO (V3 Double)-wireTangent wire = with (WireExplorer.fromWire wire) $ \explorer -> do+edgeTangentEnd :: Ptr TopoDS.Edge -> IO (V3 Double)+edgeTangentEnd e = (`with` pure) $ do+    curve <- BRep.Tool.curve e+    p1 <- liftIO . BRep.Tool.curveParamLast $ e+    liftIO . gpVecToV3 =<< Geom.Curve.dn curve p1 1++wireTangentStart :: Ptr TopoDS.Wire -> IO (V3 Double)+wireTangentStart wire = with (WireExplorer.fromWire wire) $ \explorer -> do     v1 <- WireExplorer.current explorer-    edgeTangent v1+    edgeTangentStart v1  reverseEdge :: Ptr TopoDS.Edge -> Acquire (Ptr TopoDS.Edge) reverseEdge e = do@@ -81,6 +151,19 @@     curve' <- Geom.Curve.reversed curve     MakeEdge.fromCurveAndParameters curve' lastP' firstP'  +wireEdges :: Ptr TopoDS.Wire -> Acquire [Ptr TopoDS.Edge]+wireEdges wire = do+    explorer <- WireExplorer.fromWire wire+    let runToEnd = do+            edge <- liftIO $ WireExplorer.current explorer+            edge' <- (liftIO . unsafeDowncast) =<< TopoDS.Shape.copy (upcast edge)+            liftIO $ WireExplorer.next explorer+            more <- liftIO $ WireExplorer.more explorer+            if more +                then (edge' :) <$> runToEnd+                else pure [edge']+    runToEnd+ reverseWire :: Ptr TopoDS.Wire -> Acquire (Ptr TopoDS.Wire)  reverseWire wire = do     explorer <- WireExplorer.fromWire wire@@ -128,4 +211,41 @@             runToEnd     traverse_ addWire $ wires     MakeWire.wire builder++    +edgeToWire :: Ptr TopoDS.Edge -> Acquire (Ptr TopoDS.Wire)+edgeToWire edge = do+    builder <- MakeWire.new+    liftIO $ MakeWire.addEdge builder edge+    MakeWire.wire builder++splitWires :: Ptr TopoDS.Wire -> Acquire [Ptr TopoDS.Wire]+splitWires wire = do+    explorer <- WireExplorer.fromWire wire+    let makeSegment = do+            builder <- MakeWire.new+            let addOneWire lastDelta = do+                    edge <- liftIO $ WireExplorer.current explorer+                    s' <- normalize <$> edgeTangentStart edge+                    e' <- normalize <$> edgeTangentEnd edge+                    let startIsTangent = maybe True (nearZero . (s' -)) lastDelta+                    when startIsTangent $ do+                            liftIO $ MakeWire.addEdge builder edge+                            liftIO $ WireExplorer.next explorer+                            more <- liftIO $ WireExplorer.more explorer+                            when more (addOneWire (Just e'))+            liftIO $ addOneWire Nothing+            thisWire <- MakeWire.wire builder+            more <- liftIO $ WireExplorer.more explorer+            rest <- if more+                then makeSegment +                else return []+            return $ thisWire : rest +    makeSegment++buildEdgeCurve3D :: Ptr TopoDS.Edge -> Acquire (Ptr TopoDS.Edge)+buildEdgeCurve3D edge = do +    edge' <- (liftIO . unsafeDowncast) =<< TopoDS.Shape.copy (upcast edge)+    _ <- liftIO $ BRepLib.buildCurve3d edge' 1e-5 GeomAbs.Shape.C1 14 0+    return edge' 

@@ -9,8 +9,9 @@ -} module Waterfall.Internal.Finalizers  ( unsafeFromAcquire+, unsafeFromAcquireT , fromAcquire-, fromAcquireMay+, fromAcquireT , toAcquire ) where @@ -21,6 +22,8 @@ import Control.Monad.Primitive (touch) import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromMaybe)+import Control.Monad (forM, when)+import Data.IORef (newIORef, atomicModifyIORef)  -- | Convert a resource in the `Data.Acquire.Acquire` monad to a value in IO -- the `free` action of the resource is called when the underlying value goes out of scope of the Haskell garbage collection@@ -33,18 +36,22 @@     return v      --- | variant of `fromAcquire` which registers the finalizer on the _value_ in a `Maybe` --- as opposed to the maybe itself +-- | variant of `fromAcquire` which registers the finalizer on the _value_ in a container +-- as opposed to the container itself  -- this is useful for wrapping IO actions that return the type `IO (Maybe a)` where the `Maybe` will often be finalized well before the value-fromAcquireMay :: Acquire (Maybe a) -> IO (Maybe a) -fromAcquireMay a = runResourceT $ do+-- or `IO [a]` where the List will be finalized first+fromAcquireT :: Traversable f => Acquire (f a) -> IO (f a) +fromAcquireT a = runResourceT $ do     (releaseKey, v) <- allocateAcquire a     release <- fromMaybe (pure ()) <$> unprotect releaseKey-    case v of-        Nothing -> liftIO $ Nothing <$ release-        Just v' -> do-            liftIO $ addFinalizer v' release-            return . Just $ v'+    ref <- liftIO $ newIORef (length v)+    let finalize = do+            isLast <- atomicModifyIORef ref (\count -> (count - 1, count == 1))+            when isLast release+            +    forM v $ \v' -> do +        liftIO $ addFinalizer v' finalize+        return v'  -- | Converting to a value in the `Data.Acquire.Acquire` monad, to a raw value. -- Analagous to calling `unsafePerformIO` to extract a value in the `IO` monad.@@ -56,6 +63,11 @@ {-# NOINLINE unsafeFromAcquire #-} unsafeFromAcquire :: Acquire a -> a  unsafeFromAcquire = unsafePerformIO . fromAcquire++-- | Version of `unsafeFromAcquire`  which registers the finalizer on the _value_ in a container +{-# NOINLINE unsafeFromAcquireT #-}+unsafeFromAcquireT :: (Traversable t) => Acquire (t a)  -> t a +unsafeFromAcquireT = unsafePerformIO . fromAcquireT  -- | Add a pure value (which may or may not have been generated by `unsafeFromAcquire`) back into the Acquire monad.  -- Using this action _should_ prevent the underlying value from going out of GC scope untill the resource is freed.

@@ -1,47 +1,27 @@-{-# LANGUAGE  InstanceSigs#-}+{-# LANGUAGE DerivingVia #-} {-# OPTIONS_HADDOCK not-home #-} module Waterfall.Internal.Path ( Path (..)-, joinPaths , allPathEndpoints ) where -import Data.List.NonEmpty (NonEmpty ())-import Data.Foldable (toList) import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)  import Control.Monad.IO.Class (liftIO)-import qualified OpenCascade.TopoDS as TopoDS-import Foreign.Ptr import Linear (V3 (..))-import Data.Semigroup (sconcat)-import Waterfall.Internal.Edges (allWireEndpoints, intersperseLines, joinWires)+import Waterfall.Internal.Path.Common (RawPath (..))+import Waterfall.Internal.Edges (allWireEndpoints) -- | A Path in 3D Space  -- -- Under the hood, this is represented by an OpenCascade `TopoDS.Wire`.-newtype Path = Path { rawPath :: Ptr TopoDS.Wire }+--+-- The monoid instance  Joins `Path`s, @ a <> b @ connects the end point of @ a @ to the start of @ b @, if these points are not coincident, a line is created between them.+--+newtype Path = Path { rawPath :: RawPath } deriving (Semigroup, Monoid) via RawPath  -- | Exposing this because I found it useful for debugging allPathEndpoints :: Path -> [(V3 Double, V3 Double)]-allPathEndpoints (Path raw) = unsafeFromAcquire $ do+allPathEndpoints (Path (ComplexRawPath raw)) = unsafeFromAcquire $ do     wire <- toAcquire raw     liftIO $ allWireEndpoints wire-    -joinPaths :: [Path] -> Path-joinPaths paths = Path . unsafeFromAcquire $ do-    wires <- traverse (toAcquire . rawPath) paths-    joinWires =<< intersperseLines wires---- | 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-    (<>) :: Path -> Path -> Path-    a <> b = joinPaths [a, b]-    -instance Monoid Path where-    mempty :: Path-    mempty = joinPaths []-    mconcat :: [Path] -> Path-    mconcat = joinPaths+allPathEndpoints (Path (SinglePointRawPath point)) = pure (point, point)+allPathEndpoints (Path EmptyRawPath) = []

@@ -0,0 +1,83 @@+{-# 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 (ComplexRawPath wire) = Just wire+rawPathWire _ = Nothing++rawPathToEither :: RawPath -> Maybe (Either (V3 Double) (Ptr TopoDS.Wire))+rawPathToEither EmptyRawPath = Nothing+rawPathToEither (SinglePointRawPath p) = Just . Left $ p+rawPathToEither (ComplexRawPath wire) = Just . Right $ wire++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 :: [Either (V3 Double) (Ptr TopoDS.Wire)] -> Acquire [Ptr TopoDS.Wire]+intersperseLines [] = pure []+intersperseLines [Left _x] = pure []+intersperseLines [Right x] = pure [x]+intersperseLines (a:b:xs) = do+    ea <- case a of +            Left pnt -> pure pnt+            Right wire -> do+                wire' <- toAcquire wire+                liftIO $ snd <$> wireEndpoints wire'+    sb <- case b of+            Left pnt -> pure pnt +            Right wire -> liftIO $ fst <$> wireEndpoints wire+    let prependA = either (const id) (:) a+    if distance ea sb < 1e-6+            then prependA <$> intersperseLines (b:xs)+            else prependA <$> ((:) <$> line' ea sb <*> intersperseLines (b:xs))++joinRawPaths :: [RawPath] -> RawPath+joinRawPaths paths = +    case catMaybes (rawPathToEither <$> paths) of+        [] -> EmptyRawPath+        [Left pnt] -> SinglePointRawPath pnt+        path@(h:_) -> unsafeFromAcquire $ do+            interspersed <- intersperseLines path+            case interspersed of +                [] -> pure . either SinglePointRawPath ComplexRawPath $ h+                wires -> ComplexRawPath <$> joinWires wires++instance Semigroup RawPath where+    sconcat :: NonEmpty RawPath -> RawPath+    sconcat = joinRawPaths . toList+    (<>) :: RawPath -> RawPath -> RawPath+    a <> b = joinRawPaths [a, b]+    +instance Monoid RawPath where+    mempty :: RawPath+    mempty = EmptyRawPath+    mconcat :: [RawPath] -> RawPath+    mconcat = joinRawPaths+

@@ -1,6 +1,7 @@ module Waterfall.Internal.ToOpenCascade ( v3ToVertex , v3ToPnt+, v3ToDir ) where  import Linear (V3 (..))@@ -9,11 +10,15 @@ import qualified OpenCascade.TopoDS as TopoDS import qualified OpenCascade.GP as GP import qualified OpenCascade.GP.Pnt as GP.Pnt+import qualified OpenCascade.GP.Dir as GP.Dir 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++v3ToDir :: V3 Double -> Acquire (Ptr GP.Dir)+v3ToDir (V3 x y z) = GP.Dir.new x y z  v3ToVertex :: V3 Double -> Acquire (Ptr TopoDS.Vertex) v3ToVertex v = do

@@ -8,7 +8,8 @@ These cross-sections are then interpolated to form a smooth 3d shape. -} module Waterfall.Loft-( pointedLoft+( pointedLoftWithPrecision+, pointedLoft , loft ) where @@ -16,31 +17,40 @@ import Waterfall.Internal.Path (Path, rawPath) import Waterfall.Internal.Solid (Solid (..), solidFromAcquire) import Waterfall.Internal.ToOpenCascade (v3ToVertex)+import Waterfall.Internal.Path.Common (rawPathWire) 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 @ +-- | like `pointedLoft`, but allows the user to set the precision used by the underlying algorithm+pointedLoftWithPrecision :: 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 = +pointedLoftWithPrecision 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_ paths (traverse (liftIO . ThruSections.addWire thruSections) . rawPathWire . 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 @+-- | 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 :: +    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-loft precision paths = pointedLoft precision Nothing paths Nothing+pointedLoft = pointedLoftWithPrecision 1e-6++-- | Form a loft between a series of cross-sections.+loft :: +    [Path] -- ^ Series of cross-sections that the loft will pass through+    -> Solid+loft paths = pointedLoft Nothing paths Nothing

@@ -1,5 +1,6 @@ module Waterfall.Offset  ( offset+, offsetWithTolerance ) where   import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire)@@ -32,21 +33,38 @@     go     upcast <$> MakeSolid.solid makeSolid --- | Expand or contract a `Solid` by a certain amount.--- --- This seems to be relatively fragile on Sweeps/Prisms--- (as in, may fail to produce a result)-offset :: Double    -- ^ Amount to offset by, positive values expand, negative values contract-    -> Double       -- ^ Tolerance, this can be relatively small+-- | like `offset`, but allows setting the tolerance parameter used by the algorithm +offsetWithTolerance :: +    Double       -- ^ Tolerance, this can be relatively small+    -> Double    -- ^ Amount to offset by, positive values expand, negative values contract     -> Solid        -- ^ the `Solid` to offset      -> Solid-offset value tolerance solid+offsetWithTolerance tolerance value solid     | nearZero value = solid     | otherwise =    solidFromAcquire $ do     builder <- MakeOffsetShape.new     s <- acquireSolid solid -    --liftIO $ MakeOffsetShape.performBySimple builder s value     liftIO $ MakeOffsetShape.performByJoin builder s value tolerance Mode.Skin False False GeomAbs.JoinType.Arc False      shell <- MakeShape.shape (upcast builder)     combineShellsToSolid shell++-- | Expand or contract a `Solid` by a certain amount.+-- +-- This is based on @MakeOffsetShape@ from the underlying OpenCascade library.+-- And as such, only supports the same set of `Solid`s that @MakeOffsetShape@ does.+--+-- The documentation for @MakeOffsetShape@ lists the following constraints+-- ( [link](https://dev.opencascade.org/doc/refman/html/class_b_rep_offset_a_p_i___make_offset_shape.html) ):+--+-- * All the faces of the shape S should be based on the surfaces with continuity at least C1.+-- * The offset value should be sufficiently small to avoid self-intersections in resulting shape.+--      Otherwise these self-intersections may appear inside an offset face if its initial surface is not plane or sphere or cylinder, also some non-adjacent offset faces may intersect each other. Also, some offset surfaces may "turn inside out".+-- * The algorithm may fail if the shape S contains vertices where more than 3 edges converge.+-- * Since 3d-offset algorithm involves intersection of surfaces, it is under limitations of surface intersection algorithm.+-- * A result cannot be generated if the underlying geometry of S is BSpline with continuity C0.+offset :: +    Double    -- ^ Amount to offset by, positive values expand, negative values contract+    -> Solid        -- ^ the `Solid` to offset +    -> Solid+offset = offsetWithTolerance 1e-6 

@@ -20,6 +20,8 @@ , pathEndpoints3D , closeLoop3D , reversePath3D+, splice3D+, splitPath3D ) where  import Waterfall.Internal.Path (Path(..))@@ -82,7 +84,7 @@ pathFromTo3D = pathFromTo  -- | `pathEndpoints`, with the type fixed to `Path` -pathEndpoints3D :: Path -> (V3 Double, V3 Double)+pathEndpoints3D :: Path -> Maybe (V3 Double, V3 Double) pathEndpoints3D = pathEndpoints  -- | `closeLoop` with the type fixed to `Path`@@ -92,3 +94,11 @@ -- | `reversePath` with the type fixed to `Path` reversePath3D :: Path -> Path reversePath3D = reversePath++-- | `splice` with the type fixed to `Path`+splice3D :: Path -> V3 Double -> (V3 Double, Path)+splice3D = splice++-- | `splitPath` with the type fixed to `Path`+splitPath3D :: Path -> [Path]+splitPath3D = splitPath

@@ -22,90 +22,110 @@ , pathFrom , pathFromTo , pathEndpoints+, splice , closeLoop , reversePath+, splitPath ) where import Data.Acquire import qualified OpenCascade.TopoDS as TopoDS import qualified OpenCascade.GP as GP import Foreign.Ptr+import Waterfall.Internal.Path.Common (RawPath (..)) import Waterfall.Internal.Path (Path (..)) import Waterfall.TwoD.Internal.Path2D (Path2D (..))-import Waterfall.Internal.Finalizers (unsafeFromAcquire, toAcquire)+import Waterfall.Internal.Finalizers (unsafeFromAcquire, toAcquire, unsafeFromAcquireT)+import Waterfall.Internal.FromOpenCascade (gpPntToV3)+import Waterfall.Internal.Edges (wireEndpoints, reverseWire, splitWires) import Control.Arrow (second)-import Data.Foldable (foldl', traverse_)+import Data.Foldable (foldl') import qualified OpenCascade.BRepBuilderAPI.MakeWire as MakeWire import Control.Monad.IO.Class (liftIO) import qualified OpenCascade.BRepBuilderAPI.MakeEdge as MakeEdge import qualified OpenCascade.GC.MakeArcOfCircle as MakeArcOfCircle-import OpenCascade.Inheritance (upcast)+import OpenCascade.Inheritance (upcast, unsafeDowncast) import qualified OpenCascade.NCollection.Array1 as NCollection.Array1 import qualified OpenCascade.Geom.BezierCurve as BezierCurve+import qualified OpenCascade.GP.Trsf as GP.Trsf+import qualified OpenCascade.GP.Vec as  GP.Vec+import qualified OpenCascade.BRepBuilderAPI.Transform as BRepBuilderAPI.Transform import Data.Proxy (Proxy (..))-import Linear (V3 (..), V2 (..), _xy)+import Linear (V3 (..), V2 (..), _xy, Epsilon, nearZero) import qualified OpenCascade.GP.Pnt as GP.Pnt import Control.Lens ((^.))-import Waterfall.Internal.Edges (wireEndpoints, reverseWire)-import Control.Monad ((<=<))  -- | Class used to abstract over constructing `Path` and `Path2D`  --  -- There are instances for @AnyPath (V3 Double) Path@ -- and for @AnyPath (V2 Double) Path2D@ class AnyPath point path | path -> point where-    fromWire :: Acquire (Ptr TopoDS.Wire) -> path-    toWire :: path -> Acquire (Ptr TopoDS.Wire)-    pointToGPPnt :: Proxy path -> point -> Acquire (Ptr GP.Pnt)+    reconstructPath :: RawPath -> path+    deconstructPath :: path -> RawPath+    pointToV3 :: Proxy path -> point -> V3 Double     v3ToPoint :: Proxy path -> V3 Double -> point  -edgesToPath :: (AnyPath point path) => Acquire [Ptr TopoDS.Edge] -> path-edgesToPath es = fromWire $ do-    edges <- es+pointToGPPnt :: AnyPath point path => Proxy path -> point -> Acquire (Ptr GP.Pnt)+pointToGPPnt proxy pnt = +    let (V3 x y z) = pointToV3 proxy pnt+    in GP.Pnt.new x y z ++fromWire :: AnyPath point path => Acquire (Ptr TopoDS.Wire) -> path+fromWire = reconstructPath . ComplexRawPath . unsafeFromAcquire++edgeToPath :: (AnyPath point path) => Acquire (Ptr TopoDS.Edge) -> path+edgeToPath es = fromWire $ do+    edge <- es     builder <- MakeWire.new-    liftIO $ traverse_ (MakeWire.addEdge builder) edges+    liftIO $ MakeWire.addEdge builder edge     MakeWire.wire builder  -- | A straight line between two points-line :: forall point path. (AnyPath point path) => point -> point -> path-line start end = edgesToPath $ do-    pt1 <- pointToGPPnt (Proxy :: Proxy path) start-    pt2 <- pointToGPPnt (Proxy :: Proxy path) end-    pure <$> MakeEdge.fromPnts pt1 pt2+line :: forall point path. (AnyPath point path, Epsilon point) => point -> point -> path+line start end = +    if nearZero (start - end)+        then reconstructPath . SinglePointRawPath . pointToV3 (Proxy :: Proxy path) $ start+        else edgeToPath $ do+            pt1 <- pointToGPPnt (Proxy :: Proxy path) start+            pt2 <- pointToGPPnt (Proxy :: Proxy path) end+            MakeEdge.fromPnts pt1 pt2  -- | Version of `line` designed to work with `pathFrom`-lineTo :: (AnyPath point path) => point -> point -> (point, path)+lineTo :: (AnyPath point path, Epsilon point) => point -> point -> (point, path) lineTo end = \start -> (end, line start end)   -- | Version of `line` designed to work with `pathFrom` --  -- With relative points; specifying the distance of the endpoint -- relative to the start of the line, rather than in absolute space.-lineRelative :: (AnyPath point path, Num point) => point -> point -> (point, path)+lineRelative :: (AnyPath point path, Epsilon point) => point -> point -> (point, path) lineRelative dEnd = do     end <- (+ dEnd)     lineTo end  -- | Section of a circle based on three arguments, the start point, a point on the arc, and the endpoint-arcVia :: forall point path. (AnyPath point path) => point -> point -> point -> path-arcVia start mid end = edgesToPath $ do-    s <- pointToGPPnt (Proxy :: Proxy path) start-    m <- pointToGPPnt (Proxy :: Proxy path) mid-    e <- pointToGPPnt (Proxy :: Proxy path) end-    theArc <- MakeArcOfCircle.from3Pnts s m e-    pure <$> MakeEdge.fromCurve (upcast theArc)+arcVia :: forall point path. (AnyPath point path, Epsilon point) => point -> point -> point -> path+arcVia start mid end =+    if nearZero (start - end) && nearZero (start - mid) +        then reconstructPath . SinglePointRawPath . pointToV3 (Proxy :: Proxy path) $ start+        else edgeToPath $ do+            s <- pointToGPPnt (Proxy :: Proxy path) start+            m <- pointToGPPnt (Proxy :: Proxy path) mid+            e <- pointToGPPnt (Proxy :: Proxy path) end+            theArc <- MakeArcOfCircle.from3Pnts s m e+            MakeEdge.fromCurve (upcast theArc)  -- | Version of `arcVia` designed to work with `pathFrom` -- -- The first argument is a point on the arc -- The second argument is the endpoint of the arc-arcViaTo :: (AnyPath point path) => point -> point -> point -> (point, path)+arcViaTo :: (AnyPath point path, Epsilon point) => point -> point -> point -> (point, path) arcViaTo mid end = \start -> (end, arcVia start mid end)   -- | Version of `arcVia` designed to work with `pathFrom` --  -- With relative points; specifying the distance of the midpoint and endpoint -- relative to the start of the line, rather than in absolute space.-arcViaRelative :: (AnyPath point path, Num point) => point -> point -> point -> (point, path)+arcViaRelative :: (AnyPath point path, Epsilon point) => point -> point -> point -> (point, path) arcViaRelative dMid dEnd = do     mid <- (+ dMid)      end <- (+ dEnd) @@ -114,30 +134,33 @@ -- | Bezier curve of order 3 --  -- The arguments are, the start of the curve, the two control points, and the end of the curve-bezier :: forall point path. (AnyPath point path) => point -> point -> point -> point -> path-bezier start controlPoint1 controlPoint2 end = edgesToPath $ do-    s <- pointToGPPnt (Proxy :: Proxy path) start-    c1 <- pointToGPPnt (Proxy :: Proxy path) controlPoint1-    c2 <- pointToGPPnt (Proxy :: Proxy path) controlPoint2-    e <- pointToGPPnt (Proxy :: Proxy path) end-    arr <- NCollection.Array1.newGPPntArray 1 4-    liftIO $ do -        NCollection.Array1.setValueGPPnt arr 1 s-        NCollection.Array1.setValueGPPnt arr 2 c1-        NCollection.Array1.setValueGPPnt arr 3 c2-        NCollection.Array1.setValueGPPnt arr 4 e-    b <- BezierCurve.toHandle =<< BezierCurve.fromPnts arr-    pure <$> MakeEdge.fromCurve (upcast b)+bezier :: forall point path. (AnyPath point path, Epsilon point) => point -> point -> point -> point -> path+bezier start controlPoint1 controlPoint2 end = +    if nearZero (start - end) && nearZero (start - controlPoint1) && nearZero (start - controlPoint2)+        then reconstructPath . SinglePointRawPath . pointToV3 (Proxy :: Proxy path) $ start+        else edgeToPath $ do+            s <- pointToGPPnt (Proxy :: Proxy path) start+            c1 <- pointToGPPnt (Proxy :: Proxy path) controlPoint1+            c2 <- pointToGPPnt (Proxy :: Proxy path) controlPoint2+            e <- pointToGPPnt (Proxy :: Proxy path) end+            arr <- NCollection.Array1.newGPPntArray 1 4+            liftIO $ do +                NCollection.Array1.setValueGPPnt arr 1 s+                NCollection.Array1.setValueGPPnt arr 2 c1+                NCollection.Array1.setValueGPPnt arr 3 c2+                NCollection.Array1.setValueGPPnt arr 4 e+            b <- BezierCurve.toHandle =<< BezierCurve.fromPnts arr+            MakeEdge.fromCurve (upcast b)  -- | Version of `bezier` designed to work with `pathFrom`-bezierTo :: (AnyPath point path) => point -> point -> point -> point -> (point, path)+bezierTo :: (AnyPath point path, Epsilon point) => point -> point -> point -> point -> (point, path) bezierTo controlPoint1 controlPoint2 end = \start -> (end, bezier start controlPoint1 controlPoint2 end)   -- | Version of `bezier` designed to work with `pathFrom` --  -- With relative points; specifying the distance of the control points and the endpoint -- relative to the start of the line, rather than in absolute space.-bezierRelative :: (AnyPath point path, Num point) => point -> point -> point -> point -> (point, path)+bezierRelative :: (AnyPath point path, Epsilon point) => point -> point -> point -> point -> (point, path) bezierRelative dControlPoint1 dControlPoint2 dEnd = do     controlPoint1 <- (+ dControlPoint1)     controlPoint2 <- (+ dControlPoint2)@@ -153,7 +176,7 @@ -- A typical use of `pathFrom` uses a list of functions with the suffix \"To\" or \"Relative\", e.g: -- -- @---Path.pathFrom zero +-- Path.pathFrom zero  --    [ Path.bezierRelative (V3 0 0 0.5) (V3 0.5 0.5 0.5) (V3 0.5 0.5 1) --    , Path.bezierRelative (V3 0 0 0.5) (V3 (-0.5) (-0.5) 0.5) (V3 (-0.5) (-0.5) 1) --    , Path.arcViaRelative (V3 0 1 1) (V3 0 2 0)@@ -170,40 +193,80 @@      in (end, mconcat . reverse $ allPaths)  -- | Returns the start and end of a `Path`-pathEndpoints :: forall point path. (AnyPath point path) => path -> (point, point)-pathEndpoints path = unsafeFromAcquire $ do-    wire <- toWire path-    (s, e) <- liftIO $ wireEndpoints wire-    return (v3ToPoint (Proxy :: Proxy path) s, v3ToPoint (Proxy :: Proxy path) e)+pathEndpoints :: forall point path. (AnyPath point path) => path -> Maybe (point, point)+pathEndpoints path = +    case deconstructPath path of +        ComplexRawPath p -> +            unsafeFromAcquire $ do+                wire <- toAcquire p+                (s, e) <- liftIO $ wireEndpoints wire+                return . Just $ (v3ToPoint (Proxy :: Proxy path) s, v3ToPoint (Proxy :: Proxy path) e)+        SinglePointRawPath p -> let x = v3ToPoint (Proxy :: Proxy path) p in Just (x, x)+        EmptyRawPath -> Nothing+             +-- | Convert a path into a function that can be used as an argument to `pathFrom`+--+-- Takes a path, and returns a function which takes a new start point for the path, and returns +-- tupled, the path translated onto the new start point, and the new endpoint +splice :: forall point path. (AnyPath point path, Num point) => path -> point -> (point, path)+splice path pnt =+    case deconstructPath path of+        ComplexRawPath unacquiredWire ->  +            let res = unsafeFromAcquire $ do+                    wire <- toAcquire unacquiredWire+                    (s, e) <- liftIO $ wireEndpoints wire+                    let s' = v3ToPoint (Proxy :: Proxy path) s+                        e' = v3ToPoint (Proxy :: Proxy path) e+                    gp <- pointToGPPnt (Proxy :: Proxy path) pnt+                    p <- liftIO $ gpPntToV3 gp+                    let (V3 x y z) = p - s+                    trsf <- GP.Trsf.new+                    vec <- GP.Vec.new x y z+                    liftIO $ GP.Trsf.setTranslation trsf vec+                    newWire <- (liftIO . unsafeDowncast) =<< BRepBuilderAPI.Transform.transform (upcast wire) trsf True +                    return (pnt + e' - s', newWire)+            in (fst res, fromWire (fmap snd . toAcquire $ res))+        _ -> (pnt, reconstructPath EmptyRawPath)  -- | 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 :: (AnyPath point path, Monoid path, Epsilon point) => path -> path closeLoop p = -    let (s, e) = pathEndpoints p-     in if s == e +    case pathEndpoints p of+        Just (s, e) -> if nearZero (s - e)              then p             else p <> line e s+        Nothing -> p  reversePath :: (AnyPath point path) => path -> path-reversePath = fromWire . (reverseWire <=< toWire)+reversePath p = +    case deconstructPath p of+        ComplexRawPath r -> fromWire . reverseWire $ r+        _ -> p +-- | Break a path appart 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]+ instance AnyPath (V3 Double) Path where-    fromWire :: Acquire (Ptr TopoDS.Wire) -> Path-    fromWire = Path . unsafeFromAcquire-    pointToGPPnt :: Proxy Path -> V3 Double -> Acquire (Ptr GP.Pnt)-    pointToGPPnt _ (V3 x y z) = GP.Pnt.new x y z -    toWire :: Path -> Acquire (Ptr TopoDS.Wire)-    toWire (Path ptr) = toAcquire ptr+    reconstructPath :: RawPath -> Path+    reconstructPath = Path +    pointToV3 :: Proxy Path -> V3 Double -> V3 Double+    pointToV3 _ = id+    deconstructPath :: Path -> RawPath+    deconstructPath (Path path) = path     v3ToPoint :: Proxy Path -> V3 Double -> V3 Double     v3ToPoint _ = id  instance AnyPath (V2 Double) Path2D where-    fromWire :: Acquire (Ptr TopoDS.Wire) -> Path2D-    fromWire = Path2D . unsafeFromAcquire-    pointToGPPnt :: Proxy Path2D -> V2 Double -> Acquire (Ptr GP.Pnt)-    pointToGPPnt _ (V2 x y) = GP.Pnt.new x y 0-    toWire :: Path2D -> Acquire (Ptr TopoDS.Wire)-    toWire (Path2D ptr) = toAcquire ptr+    reconstructPath :: RawPath -> Path2D+    reconstructPath = Path2D+    pointToV3 :: Proxy Path2D -> V2 Double -> V3 Double+    pointToV3 _ (V2 x y) = V3 x y 0+    deconstructPath :: Path2D -> RawPath+    deconstructPath (Path2D path) = path     v3ToPoint :: Proxy Path2D -> V3 Double -> V2 Double     v3ToPoint _  = (^. _xy)

@@ -13,6 +13,8 @@ import Waterfall.Transforms (rotate) import Control.Monad.IO.Class (liftIO) import Linear (unit, _x)+import Waterfall.Internal.Path.Common (RawPath(..))+import qualified Waterfall.Solids as Solids  -- | Construct a `Solid` of revolution from a `Path2D`. --@@ -20,11 +22,13 @@ --  -- The resulting `Solid` is rotated such that the axis of revolution is the z axis. revolution :: Path2D -> Solid-revolution (Path2D theRawPath) = rotate (unit _x) (pi/2) . solidFromAcquire $ do-    p <- toAcquire theRawPath-    axis <- GP.oy -- revolve around the y axis-    revol <- MakeRevol.fromShapeAndAx1 (upcast p) axis True-    shell <- MakeShape.shape (upcast revol)-    solidBuilder <- MakeSolid.new-    liftIO $ MakeSolid.add solidBuilder =<< unsafeDowncast shell-    MakeShape.shape (upcast solidBuilder)+revolution (Path2D (ComplexRawPath theRawPath)) = +    rotate (unit _x) (pi/2) . solidFromAcquire $ do+        p <- toAcquire theRawPath+        axis <- GP.oy -- revolve around the y axis+        revol <- MakeRevol.fromShapeAndAx1 (upcast p) axis True+        shell <- MakeShape.shape (upcast revol)+        solidBuilder <- MakeSolid.new+        liftIO $ MakeSolid.add solidBuilder =<< unsafeDowncast shell+        MakeShape.shape (upcast solidBuilder)+revolution _ = Solids.nowhere

@@ -4,7 +4,8 @@  import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire) import Waterfall.Internal.Path (Path (..))-import Waterfall.Internal.Edges (wireTangent, wireEndpoints)+import Waterfall.Internal.Path.Common (RawPath (..))+import Waterfall.Internal.Edges (wireTangentStart, wireEndpoints) import Waterfall.Internal.Finalizers (toAcquire) import Waterfall.Transforms (rotate, translate) import Waterfall.TwoD.Internal.Shape (Shape (..))@@ -16,6 +17,7 @@ import Foreign.Ptr import Linear (V3, normalize, unit, _x, _z, nearZero, cross, dot) import Data.Acquire (Acquire)+import qualified Waterfall.Solids as Solids  rotateFace :: V3 Double -> Ptr TopoDS.Shape -> Acquire (Ptr TopoDS.Shape) rotateFace v face = @@ -33,11 +35,12 @@  -- | Sweep a 2D `Shape` along a `Path`, constructing a `Solid` sweep :: Path -> Shape -> Solid-sweep (Path theRawPath) (Shape theRawShape) = solidFromAcquire $ do+sweep (Path (ComplexRawPath theRawPath)) (Shape theRawShape) = solidFromAcquire $ do     path <- toAcquire theRawPath     shape <- toAcquire theRawShape-    tangent <- liftIO $ wireTangent path+    tangent <- liftIO $ wireTangentStart path     (start,_)  <- liftIO $ wireEndpoints path     adjustedFace <- positionFace start =<< rotateFace tangent shape     builder <- MakePipe.fromWireAndShape path adjustedFace     MakeShape.shape (upcast builder)+sweep _ _ = Solids.nowhere

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} module Waterfall.Transforms ( Transformable+, matTransform , scale , uScale , rotate@@ -10,8 +11,10 @@ ) where import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire) import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire) +import Waterfall.Internal.Path.Common (RawPath(..)) import Linear.V3 (V3 (..))-import Linear ((*^), normalize, dot )+import Linear.V4 (V4 (..))+import Linear (M34, (*^), normalize, dot, (!*), unit, _w, _xyz) import qualified Linear.Quaternion as Quaternion import qualified OpenCascade.GP.Trsf as GP.Trsf import qualified OpenCascade.GP as GP@@ -27,9 +30,13 @@ import Foreign.Ptr import Waterfall.Internal.Path (Path(..)) import OpenCascade.Inheritance (upcast, unsafeDowncast)+import Data.Function ((&))+import Control.Lens ((.~))  -- | Typeclass for objects that can be manipulated in 3D space class Transformable a where+    -- | Directly transform with a transformation matrix+    matTransform :: M34 Double -> a -> a     -- | Scale by different amounts along the x, y and z axes     scale :: V3 Double -> a -> a     -- Uniform Scale@@ -42,43 +49,52 @@     -- | Mirror in the plane, which passes through the origin, tangent to the specified vector     mirror :: V3 Double -> a -> a - fromTrsfSolid :: Acquire (Ptr GP.Trsf) -> Solid -> Solid fromTrsfSolid mkTrsf s = solidFromAcquire $ do      solid <- acquireSolid s     trsf <- mkTrsf      BRepBuilderAPI.Transform.transform solid trsf True  --fromGTrsfSolid :: Acquire (Ptr GP.GTrsf) -> Solid -> Solid+fromGTrsfSolid :: Acquire (Maybe (Ptr GP.GTrsf)) -> Solid -> Solid fromGTrsfSolid mkTrsf s = solidFromAcquire $ do      solid <- acquireSolid s-    trsf <- mkTrsf -    BRepBuilderAPI.GTransform.gtransform solid trsf True -+    trsfMay <- mkTrsf +    case trsfMay of+        Just trsf -> BRepBuilderAPI.GTransform.gtransform solid trsf True +        Nothing -> pure solid -fromTrsfPath :: Acquire (Ptr GP.Trsf) -> Path -> Path-fromTrsfPath mkTrsf (Path p) = Path . unsafeFromAcquire $ do +fromTrsfPath :: (V3 Double -> V3 Double) -> Acquire (Ptr GP.Trsf) -> Path -> Path+fromTrsfPath _ mkTrsf (Path (ComplexRawPath p)) = Path . ComplexRawPath . unsafeFromAcquire $ do      path <- toAcquire p     trsf <- mkTrsf      (liftIO . unsafeDowncast) =<< BRepBuilderAPI.Transform.transform (upcast path) trsf True +fromTrsfPath f _ (Path (SinglePointRawPath v)) = Path . SinglePointRawPath . f $ v+fromTrsfPath _ _ (Path EmptyRawPath) = Path EmptyRawPath -fromGTrsfPath :: Acquire (Ptr GP.GTrsf) -> Path -> Path-fromGTrsfPath mkTrsf (Path p) = Path . unsafeFromAcquire $ do +fromGTrsfPath :: (V3 Double -> V3 Double) -> Acquire (Maybe (Ptr GP.GTrsf)) -> Path -> Path+fromGTrsfPath _ mkTrsf (Path (ComplexRawPath p)) = Path . ComplexRawPath . unsafeFromAcquire $ do      path <- toAcquire p-    trsf <- mkTrsf -    (liftIO . unsafeDowncast) =<< BRepBuilderAPI.GTransform.gtransform (upcast path) trsf True +    trsfMay <- mkTrsf +    case trsfMay of+        Just trsf -> (liftIO . unsafeDowncast) =<< BRepBuilderAPI.GTransform.gtransform (upcast path) trsf True +        Nothing -> pure path+fromGTrsfPath f _ (Path (SinglePointRawPath v)) = Path . SinglePointRawPath . f $ v+fromGTrsfPath _ _ (Path EmptyRawPath) = Path EmptyRawPath -scaleTrsf :: V3 Double -> Acquire (Ptr GP.GTrsf)-scaleTrsf (V3 x y z ) = do-    trsf <- GP.GTrsf.new -    liftIO $ do-        GP.GTrsf.setValue trsf 1 1 x-        GP.GTrsf.setValue trsf 2 2 y-        GP.GTrsf.setValue trsf 3 3 z-        GP.GTrsf.setForm trsf-        return trsf +scaleTrsf :: V3 Double -> Acquire (Maybe (Ptr GP.GTrsf))+scaleTrsf v@(V3 x y z ) = +    if v == V3 1 1 1 +        then pure Nothing+        else do+            trsf <- GP.GTrsf.new +            liftIO $ do+                GP.GTrsf.setValue trsf 1 1 x+                GP.GTrsf.setValue trsf 2 2 y+                GP.GTrsf.setValue trsf 3 3 z+                GP.GTrsf.setForm trsf+                return . Just $ trsf+ uScaleTrsf :: Double -> Acquire (Ptr GP.Trsf) uScaleTrsf factor = do     trsf <- GP.Trsf.new@@ -111,8 +127,31 @@         GP.Ax2.setDirection axis dir         GP.Trsf.setMirrorAboutAx2 trsf axis     return trsf++matrixGTrsf :: M34 Double -> Acquire (Maybe (Ptr GP.GTrsf))+matrixGTrsf (V3 (V4 1 0 0 0) (V4 0 1 0 0) (V4 0 0 1 0)) = pure Nothing+matrixGTrsf (V3 (V4 v11 v12 v13 v14) (V4 v21 v22 v23 v24) (V4 v31 v32 v33 v34)) = do+    trsf <- GP.GTrsf.new+    liftIO $ do  +        GP.GTrsf.setValue trsf 1 1 v11+        GP.GTrsf.setValue trsf 1 2 v12+        GP.GTrsf.setValue trsf 1 3 v13+        GP.GTrsf.setValue trsf 1 4 v14+        GP.GTrsf.setValue trsf 2 1 v21+        GP.GTrsf.setValue trsf 2 2 v22+        GP.GTrsf.setValue trsf 2 3 v23+        GP.GTrsf.setValue trsf 2 4 v24+        GP.GTrsf.setValue trsf 3 1 v31+        GP.GTrsf.setValue trsf 3 2 v32+        GP.GTrsf.setValue trsf 3 3 v33+        GP.GTrsf.setValue trsf 3 4 v34+        GP.GTrsf.setForm trsf+        return . pure $ trsf      instance Transformable Solid where+    matTransform :: M34 Double -> Solid -> Solid+    matTransform = fromGTrsfSolid . matrixGTrsf +         scale :: V3 Double -> Solid -> Solid     scale = fromGTrsfSolid . scaleTrsf @@ -129,23 +168,28 @@     mirror = fromTrsfSolid . mirrorTrsf  instance Transformable Path where+    matTransform :: M34 Double -> Path -> Path+    matTransform m = fromGTrsfPath (matTransform m) (matrixGTrsf m)+         scale :: V3 Double -> Path -> Path-    scale = fromGTrsfPath . scaleTrsf+    scale s = fromGTrsfPath (scale s) (scaleTrsf s)      uScale :: Double -> Path -> Path-    uScale = fromTrsfPath . uScaleTrsf+    uScale s = fromTrsfPath (uScale s) (uScaleTrsf s)      rotate :: V3 Double -> Double -> Path -> Path-    rotate axis angle = fromTrsfPath (rotateTrsf axis angle)+    rotate axis angle = fromTrsfPath (rotate axis angle) (rotateTrsf axis angle)      translate :: V3 Double -> Path -> Path-    translate = fromTrsfPath . translateTrsf+    translate v = fromTrsfPath (translate v) (translateTrsf v)          mirror :: V3 Double -> Path -> Path-    mirror = fromTrsfPath . mirrorTrsf+    mirror v = fromTrsfPath (mirror v) (mirrorTrsf v) -         instance Transformable (V3 Double) where+    matTransform :: M34 Double -> V3 Double -> V3 Double+    matTransform m v = m !* (unit _w & _xyz .~ v)+     scale :: V3 Double -> V3 Double  -> V3 Double     scale = (*) 

@@ -1,14 +1,10 @@+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_HADDOCK not-home #-} module Waterfall.TwoD.Internal.Path2D ( Path2D (..)-, joinPaths ) where -import Data.Foldable (toList)-import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)-import qualified OpenCascade.TopoDS as TopoDS-import Foreign.Ptr-import Data.Semigroup (sconcat)-import Waterfall.Internal.Edges (intersperseLines, joinWires)+import Waterfall.Internal.Path.Common (RawPath (..))  -- | A Path in 2D Space  --@@ -16,20 +12,6 @@ -- -- Please feel free to report a bug if you're able to construct a `Path2D` -- which does not lie on this plane (without using Internal functions).-newtype Path2D = Path2D { rawPath :: Ptr TopoDS.Wire }--joinPaths :: [Path2D] -> Path2D-joinPaths paths = Path2D . unsafeFromAcquire $ do-    wires <- traverse (toAcquire . rawPath) paths-    joinWires =<< intersperseLines wires---- | 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] -    -instance Monoid Path2D where-    mempty = joinPaths []-    mconcat = joinPaths+--+-- The monoid instance  Joins `Path2D`s, @ a <> b @ connects the end point of @ a @ to the start of @ b @, if these points are not coincident, a line is created between them.+newtype Path2D = Path2D { rawPath :: RawPath } deriving (Semigroup, Monoid) via RawPath

@@ -25,16 +25,15 @@ , pathEndpoints2D , closeLoop2D , reversePath2D+, splice2D+, splitPath2D ) where   import Waterfall.TwoD.Internal.Path2D (Path2D(..)) import Waterfall.TwoD.Transforms (rotate2D)-import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)-import qualified Waterfall.Internal.Edges as Internal.Edges import Linear.V2 (V2(..))-import Control.Monad.IO.Class (liftIO) import Control.Lens ((^.))-import Linear ((^*), _xy, distance, normalize, unangle)+import Linear ((^*), _xy, distance, normalize, unangle, nearZero) import Waterfall.Path.Common  data Sense = Clockwise | Counterclockwise deriving (Eq, Show)@@ -81,12 +80,15 @@ -- -- This can be used to construct paths with rotational symmetry, such as regular polygons, or gears. repeatLooping :: Path2D -> Path2D-repeatLooping p = Path2D . unsafeFromAcquire $ do-    path <- toAcquire . rawPath $ p -    (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 (fromIntegral n * a) p | n <- [0..times]]+repeatLooping p = +    case pathEndpoints2D p of+        Nothing -> p+        Just (s, e) ->+            let a = unangle (e ^. _xy) - unangle (s ^. _xy)+            in if nearZero a +                then mempty+                else let times :: Integer = abs . round $ pi * 2 / a +                      in mconcat $ [rotate2D (fromIntegral n * a) p | n <- [0..times]]   -- $reexports@@ -138,7 +140,7 @@ pathFromTo2D = pathFromTo  -- | `pathEndpoints`, with the type fixed to `Path2D` -pathEndpoints2D :: Path2D -> (V2 Double, V2 Double)+pathEndpoints2D :: Path2D -> Maybe (V2 Double, V2 Double) pathEndpoints2D = pathEndpoints  -- | `closeLoop` with the type fixed to `Path2D`@@ -148,3 +150,12 @@ -- | `reversePath` with the type fixed to `Path2D` reversePath2D :: Path2D -> Path2D reversePath2D = reversePath+++-- | `splice` with the type fixed to `Path2D`+splice2D :: Path2D -> V2 Double -> (V2 Double, Path2D)+splice2D = splice++-- | `splitPath` with the type fixed to `Path2D`+splitPath2D :: Path2D -> [Path2D]+splitPath2D = splitPath

@@ -1,6 +1,7 @@ module Waterfall.TwoD.Shape ( Shape-, fromPath+, makeShape+, shapePaths , unitCircle , unitSquare , centeredSquare@@ -10,20 +11,36 @@ import Waterfall.TwoD.Internal.Path2D (Path2D (..)) import Waterfall.TwoD.Transforms (translate2D) import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)+import Waterfall.Internal.Edges (allWires) import qualified OpenCascade.BRepBuilderAPI.MakeFace as MakeFace import OpenCascade.Inheritance (upcast) import Linear (unit, _x, _y, zero, V2 (..)) import Waterfall.Path.Common (pathFrom, arcViaTo, lineTo)+import Waterfall.Internal.Path.Common (RawPath(ComplexRawPath))  -- | Construct a 2D Shape from a closed path -fromPath :: Path2D -> Shape-fromPath (Path2D r)= Shape . unsafeFromAcquire  $ do+makeShape :: Path2D -> Shape+makeShape (Path2D (ComplexRawPath r)) = Shape . unsafeFromAcquire  $ do     p <- toAcquire r     upcast <$> (MakeFace.face =<< MakeFace.fromWire p False)+makeShape _ = Shape . unsafeFromAcquire $+    upcast <$> (MakeFace.face =<< MakeFace.new) +-- | Get the paths back from a 2D shape+-- +-- Ideally:+--+-- @+-- shapePaths . fromPath ≡ pure+-- @+shapePaths :: Shape -> [Path2D] +shapePaths (Shape r) = fmap (Path2D . ComplexRawPath) . unsafeFromAcquire $ do+    s <- toAcquire r +    allWires s + -- | Circle with radius 1, centered on the origin unitCircle :: Shape-unitCircle = fromPath $ pathFrom (unit _x)+unitCircle = makeShape $ pathFrom (unit _x)                 [ arcViaTo (unit _y) (negate $ unit _x)                 , arcViaTo (negate $ unit _y) (unit _x)                 ]@@ -31,7 +48,7 @@ -- | Square with side length of 1, one vertex on the origin, another on \( (1, 1) \) unitSquare :: Shape unitSquare =-    fromPath $ pathFrom zero+    makeShape $ pathFrom zero         [ lineTo (unit _x)         , lineTo (V2 1 1)         , lineTo (unit _y)

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} module Waterfall.TwoD.Transforms ( Transformable2D+, matTransform2D , rotate2D , scale2D , uScale2D@@ -11,8 +12,7 @@  import Waterfall.TwoD.Internal.Path2D (Path2D (..)) import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)-import Linear.V2 (V2 (..))-import Linear ((*^), normalize, dot)+import Linear ((*^), normalize, dot, V3 (..), V2 (..), (!*), _xy, _z, unit, M23) import qualified OpenCascade.GP.Trsf as GP.Trsf import qualified OpenCascade.GP as GP import qualified OpenCascade.GP.GTrsf as GP.GTrsf@@ -27,9 +27,16 @@ import Data.Acquire import Foreign.Ptr import Waterfall.TwoD.Internal.Shape (Shape(..))+import Data.Function ((&))+import Control.Lens ((.~), (%~))+import Control.Monad (forM)+import Waterfall.Internal.Path.Common (RawPath(..))+import Waterfall.Internal.Diagram (RawDiagram (..))  -- | Typeclass for objects that can be manipulated in 2D space class Transformable2D a where+    -- | Directly transform with a transformation matrix+    matTransform2D :: M23 Double -> a -> a     -- | Rotate by an angle (in radians) about the origin     rotate2D :: Double -> a -> a     -- | Scale by different amounts along the x and y axes@@ -44,31 +51,66 @@     -- the mirror is in the line / tangent / to the vector, not in the line / parallel / to the vector     mirror2D :: V2 Double -> a -> a -fromTrsfPath :: Acquire (Ptr GP.Trsf) -> Path2D -> Path2D-fromTrsfPath mkTrsf (Path2D p) = Path2D . unsafeFromAcquire $ do +fromTrsfPath :: (V2 Double -> V2 Double) -> Acquire (Ptr GP.Trsf) -> Path2D -> Path2D+fromTrsfPath _ mkTrsf (Path2D (ComplexRawPath p)) = Path2D . ComplexRawPath . unsafeFromAcquire $ do      path <- toAcquire p     trsf <- mkTrsf      (liftIO . unsafeDowncast) =<< BRepBuilderAPI.Transform.transform (upcast path) trsf True +fromTrsfPath f _ (Path2D (SinglePointRawPath v)) = Path2D . SinglePointRawPath $ (v & _xy %~ f)+fromTrsfPath _ _ (Path2D EmptyRawPath) = Path2D EmptyRawPath  fromTrsfShape :: Acquire (Ptr GP.Trsf) -> Shape -> Shape fromTrsfShape mkTrsf (Shape theRawShape) = Shape . unsafeFromAcquire $ do      shape <- toAcquire theRawShape     trsf <- mkTrsf      BRepBuilderAPI.Transform.transform shape trsf True -     -fromGTrsfPath :: Acquire (Ptr GP.GTrsf) -> Path2D -> Path2D-fromGTrsfPath mkTrsf (Path2D p) = Path2D . unsafeFromAcquire  $ do +fromGTrsfPath :: (V2 Double -> V2 Double) -> Acquire (Maybe (Ptr GP.GTrsf)) -> Path2D -> Path2D+fromGTrsfPath _ mkTrsf (Path2D (ComplexRawPath p)) = Path2D . ComplexRawPath . unsafeFromAcquire  $ do      path <- toAcquire p-    trsf <- mkTrsf -    (liftIO . unsafeDowncast) =<< BRepBuilderAPI.GTransform.gtransform (upcast path) trsf True +    trsfMay <- mkTrsf +    case trsfMay of+        Just trsf -> (liftIO . unsafeDowncast) =<< BRepBuilderAPI.GTransform.gtransform (upcast path) trsf True +        Nothing -> pure path+fromGTrsfPath f _ (Path2D (SinglePointRawPath v)) = Path2D . SinglePointRawPath $ (v & _xy %~ f)+fromGTrsfPath _ _ (Path2D EmptyRawPath) = Path2D EmptyRawPath -fromGTrsfShape :: Acquire (Ptr GP.GTrsf) -> Shape -> Shape+fromGTrsfShape :: Acquire (Maybe (Ptr GP.GTrsf)) -> Shape -> Shape fromGTrsfShape mkTrsf (Shape theRawShape) = Shape . unsafeFromAcquire $ do      shape <- toAcquire theRawShape +    trsfMay <- mkTrsf +    case trsfMay of+        Just trsf -> BRepBuilderAPI.GTransform.gtransform shape trsf True +        Nothing -> pure shape++fromTrsfDiagram :: Acquire (Ptr GP.Trsf) -> RawDiagram -> RawDiagram+fromTrsfDiagram mkTrsf (RawDiagram runTheDiagram) = RawDiagram $ \lt v is3D -> do +    edges <- runTheDiagram lt v is3D     trsf <- mkTrsf -    BRepBuilderAPI.GTransform.gtransform shape trsf True +    forM edges $ \s -> (liftIO . unsafeDowncast) =<< BRepBuilderAPI.Transform.transform (upcast s) trsf True +fromGTrsfDiagram :: Acquire (Maybe (Ptr GP.GTrsf)) -> RawDiagram -> RawDiagram+fromGTrsfDiagram mkTrsf (RawDiagram runTheDiagram) = RawDiagram $ \lt v is3D -> do +    edges <- runTheDiagram lt v is3D+    trsfMay <- mkTrsf +    case trsfMay of+        Just trsf -> forM edges $ \s -> (liftIO . unsafeDowncast) =<< BRepBuilderAPI.GTransform.gtransform (upcast s) trsf True +        Nothing -> pure edges++matrixGTrsf :: M23 Double -> Acquire (Maybe (Ptr GP.GTrsf))+matrixGTrsf (V2 (V3 1 0 0) (V3 0 1 0)) = pure Nothing+matrixGTrsf (V2 (V3 v11 v12 v13) (V3 v21 v22 v23)) = do+    trsf <- GP.GTrsf.new+    liftIO $ do  +        GP.GTrsf.setValue trsf 1 1 v11+        GP.GTrsf.setValue trsf 1 2 v12+        GP.GTrsf.setValue trsf 1 4 v13+        GP.GTrsf.setValue trsf 2 1 v21+        GP.GTrsf.setValue trsf 2 2 v22+        GP.GTrsf.setValue trsf 2 4 v23+        GP.GTrsf.setForm trsf+        return . pure $ trsf+ rotateTrsf :: Double -> Acquire (Ptr GP.Trsf) rotateTrsf angle = do     trsf <- GP.Trsf.new@@ -78,15 +120,18 @@     liftIO $ GP.Trsf.setRotationAboutAxisAngle trsf axis angle     return trsf -scaleGTrsf :: V2 Double -> Acquire (Ptr GP.GTrsf)-scaleGTrsf (V2 x y) = do-    trsf <- GP.GTrsf.new -    liftIO $ do-        GP.GTrsf.setValue trsf 1 1 x-        GP.GTrsf.setValue trsf 2 2 y-        GP.GTrsf.setValue trsf 3 3 1-        GP.GTrsf.setForm trsf-        return trsf+scaleGTrsf :: V2 Double -> Acquire (Maybe (Ptr GP.GTrsf))+scaleGTrsf v@(V2 x y) = +    if v == V2 1 1 +        then pure Nothing+        else do+            trsf <- GP.GTrsf.new +            liftIO $ do+                GP.GTrsf.setValue trsf 1 1 x+                GP.GTrsf.setValue trsf 2 2 y+                GP.GTrsf.setValue trsf 3 3 1+                GP.GTrsf.setForm trsf+                return . Just $ trsf  uScaleTrsf :: Double -> Acquire (Ptr GP.Trsf)  uScaleTrsf factor = do@@ -113,24 +158,28 @@     return trsf  instance Transformable2D Path2D where+    matTransform2D :: M23 Double -> Path2D -> Path2D+    matTransform2D m = fromGTrsfPath (matTransform2D m) (matrixGTrsf m)+     rotate2D :: Double -> Path2D -> Path2D-    rotate2D = fromTrsfPath . rotateTrsf  +    rotate2D a = fromTrsfPath (rotate2D a) (rotateTrsf a)          scale2D :: V2 Double -> Path2D -> Path2D-    scale2D = fromGTrsfPath . scaleGTrsf+    scale2D s = fromGTrsfPath (scale2D s) (scaleGTrsf s)      uScale2D :: Double -> Path2D -> Path2D-    uScale2D = fromTrsfPath . uScaleTrsf+    uScale2D s = fromTrsfPath (uScale2D s) (uScaleTrsf s)      translate2D :: V2 Double -> Path2D -> Path2D-    translate2D = fromTrsfPath .translateTrsf+    translate2D v = fromTrsfPath (translate2D v) (translateTrsf v)      mirror2D :: V2 Double -> Path2D -> Path2D-    mirror2D = fromTrsfPath . mirrorTrsf-    -+    mirror2D v = fromTrsfPath (mirror2D v) (mirrorTrsf v)  instance Transformable2D Shape where+    matTransform2D :: M23 Double -> Shape -> Shape+    matTransform2D = fromGTrsfShape . matrixGTrsf+     rotate2D :: Double -> Shape -> Shape     rotate2D = fromTrsfShape . rotateTrsf       @@ -146,7 +195,29 @@     mirror2D :: V2 Double -> Shape -> Shape     mirror2D = fromTrsfShape . mirrorTrsf +instance Transformable2D RawDiagram where+    matTransform2D :: M23 Double -> RawDiagram -> RawDiagram+    matTransform2D m = fromGTrsfDiagram (matrixGTrsf m)++    rotate2D :: Double -> RawDiagram -> RawDiagram+    rotate2D a = fromTrsfDiagram (rotateTrsf a)+    +    scale2D :: V2 Double -> RawDiagram -> RawDiagram+    scale2D s = fromGTrsfDiagram (scaleGTrsf s)++    uScale2D :: Double -> RawDiagram -> RawDiagram+    uScale2D s = fromTrsfDiagram (uScaleTrsf s)++    translate2D :: V2 Double -> RawDiagram -> RawDiagram+    translate2D v = fromTrsfDiagram (translateTrsf v)++    mirror2D :: V2 Double -> RawDiagram -> RawDiagram+    mirror2D v = fromTrsfDiagram (mirrorTrsf v)+ instance Transformable2D (V2 Double) where+    matTransform2D :: M23 Double -> V2 Double -> V2 Double+    matTransform2D m v = m !* (unit _z & _xy .~ v)+     scale2D :: V2 Double -> V2 Double  -> V2 Double     scale2D = (*) 

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack  name:           waterfall-cad-version:        0.4.0.0+version:        0.5.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@@ -33,11 +33,14 @@       Waterfall.Booleans.Operators       Waterfall.BoundingBox.AxisAligned       Waterfall.BoundingBox.Oriented+      Waterfall.Diagram       Waterfall.Fillet+      Waterfall.Internal.Diagram       Waterfall.Internal.Edges       Waterfall.Internal.Finalizers       Waterfall.Internal.FromOpenCascade       Waterfall.Internal.Path+      Waterfall.Internal.Path.Common       Waterfall.Internal.Remesh       Waterfall.Internal.Solid       Waterfall.Internal.ToOpenCascade@@ -67,7 +70,7 @@     , lattices >=2.0 && <3     , lens ==5.*     , linear >=1.21 && <2-    , opencascade-hs >=0.4.0.0 && <0.5+    , opencascade-hs >=0.5.0.0 && <0.6     , primitive >=0.7 && <0.10     , resourcet >=1.2 && <1.4   default-language: Haskell2010