packages feed

waterfall-cad 0.1.2.2 → 0.2.0.0

raw patch · 25 files changed

+391/−113 lines, 25 filesdep +primitivedep ~opencascade-hs

Dependencies added: primitive

Dependency ranges changed: opencascade-hs

Files

CHANGELOG.md view
@@ -9,6 +9,29 @@  ## Unreleased +## 0.2.0.0++### Added ++- the following `volume`, `momentOfInertia` and `centerOfMass` queries in `Waterfall.Solids`+    - `volume`+    - `momentOfInertia`+    - `centerOfMass`+- `aabbToSolid` to `Waterfall.Solids` (converts the output of `axisAlignedBoundingBox` into a solid)+- `Waterfall.BoundingBox.AxisAligned`, for calculating (and reifying) an (axis aligned) bounding box of a solid +- `Waterfall.BoundingBox.Oriented`, for calculating (and reifying) an (oriented) bounding box of a solid ++### Changed ++- Changed the representation of `Solid` (and other Waterfall values) from a newtype wrapper to `Data.Acquire` to a naked `Ptr`, with destructors called using Finalizers.+    - This means it's possible to support "queries", like calculating the volume of a Solid+    - It also means there's some risk of exceptions being thrown when working with plain values, which wasn't present before+- `Waterfall.Text.fontFromPath` and `Waterfall.Text.fontFromSystem` now return `IO` actions rather than embedding the action into the underlying `Shape`++### Fixed++- Typo in documentation for `Waterfall.Solids.unitCone` + ## 0.1.2.2 - 2024-01-09   ### Fixed
src/Waterfall.hs view
@@ -1,6 +1,8 @@ module Waterfall  ( module Waterfall.Booleans , module Waterfall.Booleans.Operators+, module Waterfall.BoundingBox.AxisAligned+, module Waterfall.BoundingBox.Oriented , module Waterfall.Fillet , module Waterfall.IO , module Waterfall.Offset@@ -18,6 +20,8 @@  import Waterfall.Booleans import Waterfall.Booleans.Operators+import Waterfall.BoundingBox.AxisAligned+import Waterfall.BoundingBox.Oriented import Waterfall.Fillet import Waterfall.IO import Waterfall.Offset
+ src/Waterfall/BoundingBox/AxisAligned.hs view
@@ -0,0 +1,37 @@+module Waterfall.BoundingBox.AxisAligned+( axisAlignedBoundingBox+, aabbToSolid+) where+import Waterfall.Internal.Solid(Solid, acquireSolid)+import Waterfall.Internal.Finalizers (unsafeFromAcquire)+import Waterfall.Internal.FromOpenCascade (gpPntToV3)+import Waterfall.Solids (box, volume)+import Waterfall.Transforms (translate)+import Linear (V3 (..), (^-^))+import qualified OpenCascade.Bnd.Box as Bnd.Box+import qualified OpenCascade.BRepBndLib as BRepBndLib+import Control.Monad.IO.Class (liftIO)++-- | Return the smallest Axis Aligned Bounding Box (AABB) that contains the Solid.+-- +-- If computable, the AABB is returned in the form '(lo, hi)',+-- where 'lo' is the vertex of the box with the lowest individual values,+-- and 'hi' is the vertex with the highest values.+axisAlignedBoundingBox :: Solid -> Maybe (V3 Double, V3 Double)+axisAlignedBoundingBox s =  +    if volume s <= 0+        then Nothing +        else Just . unsafeFromAcquire $ do+            solid <- acquireSolid s+            theBox <- Bnd.Box.new+            liftIO $ BRepBndLib.addOptimal solid theBox True False+            p1 <- liftIO . gpPntToV3 =<< Bnd.Box.cornerMin theBox+            p2 <- liftIO . gpPntToV3 =<< Bnd.Box.cornerMax theBox+            return (p1, p2)++-- | A cuboid, specified by two diagonal vertices.+--  +-- This can be used to make a solid from the output of `axisAlignedBoundingBox` +aabbToSolid :: (V3 Double, V3 Double) -- ^ if this argument input is `(lo, hi)`, one vertex of the cuboid is placed at `lo`, the oposite vertex is at `hi`+    -> Solid+aabbToSolid (lo, hi) = translate lo $ box (hi ^-^ lo)
+ src/Waterfall/BoundingBox/Oriented.hs view
@@ -0,0 +1,92 @@+module Waterfall.BoundingBox.Oriented+( OrientedBoundingBox+, obbCenter+, obbSideX+, obbSideY+, obbSideZ+, orientedBoundingBox+, obbToSolid+) where++import Linear (V3 (..), normalize, (^*))+import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire)+import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)+import Waterfall.Internal.FromOpenCascade (gpXYZToV3)+import Foreign.Ptr (Ptr)+import Waterfall.Solids (volume, box)+import Waterfall.Transforms (translate)+import qualified OpenCascade.Bnd.OBB as OBB+import OpenCascade.Bnd.OBB (OBB)+import OpenCascade.GP.Types (XYZ)+import qualified OpenCascade.GP as GP+import qualified OpenCascade.GP.Ax3 as Ax3+import qualified OpenCascade.GP.Trsf as Trsf+import qualified OpenCascade.BRepBndLib as BRepBndLib+import qualified OpenCascade.BRepBuilderAPI.Transform  as BRepBuilderAPI.Transform+import Data.Acquire (Acquire)+import Control.Monad.IO.Class (liftIO)+import Control.Monad ((<=<))++-- | An OrientedBoundingBox may be a tighter fit for a Shape than an axis aligned bounding box would be+-- +data OrientedBoundingBox = OrientedBoundingBox { rawOBB :: Ptr OBB }++-- | Compute an OrientedBoundingBox for a solid+orientedBoundingBox :: Solid -> Maybe OrientedBoundingBox+orientedBoundingBox s = +    if volume s == 0+        then Nothing +        else Just . OrientedBoundingBox . unsafeFromAcquire $ do+            obb <- OBB.new+            solid <- acquireSolid s+            liftIO $ BRepBndLib.addOBB solid obb True True True+            return obb++queryOBB :: (Ptr OBB -> Acquire (V3 Double)) -> OrientedBoundingBox -> V3 Double+queryOBB f = unsafeFromAcquire . ( f <=< toAcquire . rawOBB)++-- | The center point of an `OrientedBoundingBox`+obbCenter :: OrientedBoundingBox -> V3 Double+obbCenter = queryOBB (liftIO . gpXYZToV3 <=< OBB.center)++getSide :: (Ptr OBB -> Acquire (Ptr XYZ)) -> (Ptr OBB -> IO Double) -> OrientedBoundingBox -> V3 Double+getSide fxyz fLength = queryOBB $ \obb -> do+    side <- liftIO . gpXYZToV3 =<< fxyz obb+    len <- liftIO $ fLength obb+    return $ normalize side ^* len++-- | The "X" side of the oriented bounding box.+--+-- This is measured from the center to one Face.+-- So the length of this vector is _half_ of the side length of the bounding box.+obbSideX :: OrientedBoundingBox -> V3 Double +obbSideX = getSide OBB.xDirection OBB.xHSize+    +-- | The "Y" side of the oriented bounding box.+--+-- This is measured from the center to one face.+-- So the length of this vector is _half_ of the side length of the bounding box.+obbSideY :: OrientedBoundingBox -> V3 Double +obbSideY = getSide OBB.yDirection OBB.yHSize+    +-- | the "Z" side of the oriented bounding box+--+-- This is measured from the center to one face.+-- So the length of this vector is _half_ of the side length of the bounding box.+obbSideZ :: OrientedBoundingBox -> V3 Double+obbSideZ =  getSide OBB.zDirection OBB.zHSize++-- | Reify an `OrientedBoundingBox` as a `Solid`+obbToSolid :: OrientedBoundingBox -> Solid+obbToSolid obb = solidFromAcquire $ do+    obb' <- toAcquire . rawOBB $ obb+    x <- liftIO . OBB.xHSize $ obb'+    y <- liftIO . OBB.yHSize $ obb'+    z <- liftIO . OBB.zHSize $ obb'+    let halfBox = V3 x y z+    unpositioned <- acquireSolid . translate (negate halfBox) $ box (V3 x y z ^* 2)+    position <- OBB.position obb'+    o <- Ax3.fromAx2 =<< GP.xoy+    trsf <- Trsf.new+    liftIO $ Trsf.setDisplacement trsf o position+    BRepBuilderAPI.Transform.transform unpositioned trsf True
src/Waterfall/Fillet.hs view
@@ -4,7 +4,7 @@ , roundIndexedConditionalFillet ) where -import Waterfall.Internal.Solid (Solid (..))+import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire) import Waterfall.Internal.Edges (edgeEndpoints) import qualified OpenCascade.BRepFilletAPI.MakeFillet as MakeFillet import qualified OpenCascade.BRepBuilderAPI.MakeShape as MakeShape@@ -47,8 +47,8 @@ -- -- Being able to selectively round\/fillet based on edge index is an \"easy\" way to round\/fillet these shapes.  roundIndexedConditionalFillet :: (Integer -> (V3 Double, V3 Double) -> Maybe Double) -> Solid -> Solid-roundIndexedConditionalFillet radiusFunction (Solid run) = Solid $ do-    s <- run+roundIndexedConditionalFillet radiusFunction solid = solidFromAcquire $ do+    s <- acquireSolid solid     builder <- MakeFillet.fromShape s      explorer <- Explorer.new s ShapeEnum.Edge
src/Waterfall/IO.hs view
@@ -11,6 +11,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad (void, unless) import System.IO (hPutStrLn, stderr)+import Waterfall.Internal.Finalizers (toAcquire) import Data.Acquire  -- | Write a `Solid` to a (binary) STL file at a given path@@ -21,8 +22,8 @@ -- -- The deflection is the maximum allowable distance between a curve and the generated triangulation. writeSTL :: Double -> FilePath -> Solid -> IO ()-writeSTL linDeflection filepath (Solid run) = (`withAcquire` pure) $ do-    s <- run+writeSTL linDeflection filepath (Solid ptr) = (`withAcquire` pure) $ do+    s <- toAcquire ptr     mesh <- BRepMesh.IncrementalMesh.fromShapeAndLinDeflection s linDeflection     liftIO $ BRepMesh.IncrementalMesh.perform mesh     writer <- StlWriter.new@@ -36,8 +37,8 @@ -- -- STEP files can be imported by [FreeCAD](https://www.freecad.org/) writeSTEP :: FilePath -> Solid -> IO ()-writeSTEP filepath (Solid run) = (`withAcquire` pure) $ do-    s <- run+writeSTEP filepath (Solid ptr) = (`withAcquire` pure) $ do+    s <- toAcquire ptr     writer <- StepWriter.new     _ <- liftIO $ StepWriter.transfer writer s StepModelType.Asls True     void . liftIO $ StepWriter.write writer filepath
src/Waterfall/Internal/Edges.hs view
@@ -1,6 +1,5 @@ module Waterfall.Internal.Edges-( gpPntToV3-, edgeEndpoints+( edgeEndpoints , wireEndpoints , wireTangent ) where@@ -9,20 +8,13 @@ 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.GP.Pnt as GP.Pnt-import qualified OpenCascade.GP as GP+import Waterfall.Internal.FromOpenCascade (gpPntToV3, gpVecToV3) import Data.Acquire import Control.Monad.IO.Class (liftIO) import Linear (V3 (..)) import Foreign.Ptr-import qualified OpenCascade.GP.Vec as GP.Vec  -gpPntToV3 :: Ptr GP.Pnt -> IO (V3 Double)-gpPntToV3 pnt = V3 <$> GP.Pnt.getX pnt <*> GP.Pnt.getY pnt <*> GP.Pnt.getZ pnt--gpVecToV3 :: Ptr GP.Vec -> IO (V3 Double)-gpVecToV3 vec = V3 <$> GP.Vec.getX vec <*> GP.Vec.getY vec <*> GP.Vec.getZ vec  edgeEndpoints :: Ptr TopoDS.Edge -> IO (V3 Double, V3 Double) edgeEndpoints edge = (`with` pure) $ do
+ src/Waterfall/Internal/Finalizers.hs view
@@ -0,0 +1,48 @@+{-| +Module: Waterfall.Internal.Finalizers++These functions exist because the underlying `opencascade-hs` library, +makes heavy use of `Data.Acquire` from `resourcet` to handle memory management.+However `waterfall-cad` does not (at the highest level) keep values in the `Acquire` monad. +(This is required to support functions like `Waterfall.Solids.volume`, which return pure Haskell primitives.)++-}+module Waterfall.Internal.Finalizers +( unsafeFromAcquire+, fromAcquire+, toAcquire+) where++import System.IO.Unsafe (unsafePerformIO)+import Control.Monad.Trans.Resource (runResourceT, unprotect)+import Data.Acquire (Acquire, mkAcquire, allocateAcquire)+import System.Mem.Weak (addFinalizer)+import Control.Monad.Primitive (touch)+import Control.Monad.IO.Class (liftIO)+import Data.Maybe (fromMaybe)++-- | 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+-- so may run at an unpredictable time.+fromAcquire :: Acquire a -> IO a +fromAcquire a = runResourceT $ do+    (releaseKey, v) <- allocateAcquire a+    release <- fromMaybe (pure ()) <$> unprotect releaseKey+    liftIO $ addFinalizer v release+    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.+-- The same constraints as apply to `unsafePerformIO` apply to this method. +-- That is, it should only be used on "philosophically pure" actions.+--+-- The `free` action of the resource is called when the underlying value goes out of scope of the Haskell garbage collection,+-- so may run at an unpredictable time.+{-# NOINLINE unsafeFromAcquire #-}+unsafeFromAcquire :: Acquire a -> a +unsafeFromAcquire = unsafePerformIO . fromAcquire++-- | 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.+toAcquire :: a -> Acquire a+toAcquire value = mkAcquire (pure value) touch
+ src/Waterfall/Internal/FromOpenCascade.hs view
@@ -0,0 +1,21 @@+module Waterfall.Internal.FromOpenCascade+( gpPntToV3+, gpVecToV3+, gpXYZToV3+) where++import qualified OpenCascade.GP.Pnt as GP.Pnt+import qualified OpenCascade.GP.Vec as GP.Vec+import qualified OpenCascade.GP.XYZ as GP.XYZ+import qualified OpenCascade.GP as GP+import Linear (V3 (..))+import Foreign.Ptr+    +gpPntToV3 :: Ptr GP.Pnt -> IO (V3 Double)+gpPntToV3 pnt = V3 <$> GP.Pnt.getX pnt <*> GP.Pnt.getY pnt <*> GP.Pnt.getZ pnt++gpVecToV3 :: Ptr GP.Vec -> IO (V3 Double)+gpVecToV3 vec = V3 <$> GP.Vec.getX vec <*> GP.Vec.getY vec <*> GP.Vec.getZ vec++gpXYZToV3 :: Ptr GP.XYZ -> IO (V3 Double)+gpXYZToV3 xyz = V3 <$> GP.XYZ.x xyz <*> GP.XYZ.y xyz <*> GP.XYZ.z xyz
src/Waterfall/Internal/Path.hs view
@@ -7,7 +7,7 @@  import Data.List.NonEmpty (NonEmpty ()) import Data.Foldable (traverse_, toList)-import Data.Acquire+import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)  import Control.Monad ((<=<)) import Control.Monad.IO.Class (liftIO) import qualified OpenCascade.TopoDS as TopoDS@@ -18,12 +18,12 @@ -- | A Path in 3D Space  -- -- Under the hood, this is represented by an OpenCascade `TopoDS.Wire`.-newtype Path = Path { runPath :: Acquire (Ptr TopoDS.Wire) }+newtype Path = Path { rawPath :: Ptr TopoDS.Wire }  joinPaths :: [Path] -> Path-joinPaths paths = Path $ do+joinPaths paths = Path . unsafeFromAcquire $ do     builder <- MakeWire.new-    traverse_ (liftIO . MakeWire.addWire builder <=< runPath) paths+    traverse_ (liftIO . MakeWire.addWire builder <=< toAcquire . rawPath) paths     MakeWire.wire builder  -- | The Semigroup for `Path` attempts to join two paths that share a common endpoint.
src/Waterfall/Internal/Solid.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE InstanceSigs #-} module Waterfall.Internal.Solid  ( Solid (..)+, acquireSolid+, solidFromAcquire , union , difference , intersection@@ -22,6 +24,7 @@ import qualified OpenCascade.BRepAlgoAPI.Common as Common import qualified OpenCascade.BRepBuilderAPI.MakeSolid as MakeSolid import OpenCascade.Inheritance (upcast)+import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)  -- | The Boundary Representation of a solid object. --@@ -33,12 +36,18 @@ -- While you shouldn't need to know what this means to use the library, -- please feel free to report a bug if you're able to construct a `Solid` -- where this isnt' the case (without using internal functions).-newtype Solid = Solid { runSolid :: Acquire (Ptr TopoDS.Shape.Shape) }+newtype Solid = Solid { rawSolid :: Ptr TopoDS.Shape.Shape } +acquireSolid :: Solid -> Acquire (Ptr TopoDS.Shape.Shape)+acquireSolid (Solid ptr) = toAcquire ptr++solidFromAcquire :: Acquire (Ptr TopoDS.Shape.Shape) -> Solid+solidFromAcquire = Solid . unsafeFromAcquire+ -- | print debug information about a Solid when it's evaluated  -- exposes the properties of the underlying OpenCacade.TopoDS.Shape debug :: String -> Solid -> Solid-debug name (Solid runTheSolid) = +debug name (Solid ptr) =      let          fshow :: Show a => IO a -> IO String          fshow = fmap show@@ -56,14 +65,14 @@             , ("convex", fshow . TopoDS.Shape.convex)             , ("nbChildren", fshow . TopoDS.Shape.nbChildren)             ]-    in Solid $ do-    s <- runTheSolid-    liftIO $ do -        putStrLn name-        forM_ actions $ \(actionName, value) -> do-            putStrLn ("\t" <> actionName)-            putStrLn . ("\t\t" <>) =<< value s-    return s+    in Solid $ unsafeFromAcquire $ do+        s <- toAcquire ptr+        liftIO $ do +            putStrLn name+            forM_ actions $ \(actionName, value) -> do+                putStrLn ("\t" <> actionName)+                putStrLn . ("\t\t" <>) =<< value s+        return s  {-- -- TODO: this does not work, need to fix@@ -78,21 +87,21 @@ -- -- Be warned that @complement nowhere@ does not appear to work correctly. complement :: Solid -> Solid-complement (Solid run) = Solid $ TopoDS.Shape.complemented =<< run+complement (Solid ptr) = Solid . unsafeFromAcquire $ TopoDS.Shape.complemented =<< toAcquire ptr  -- | An empty solid -- -- Be warned that @complement nowhere@ does not appear to work correctly. nowhere :: Solid -nowhere =  Solid $ upcast <$> (MakeSolid.solid =<< MakeSolid.new)+nowhere =  Solid . unsafeFromAcquire $ upcast <$> (MakeSolid.solid =<< MakeSolid.new)  -- defining the boolean CSG operators here, rather than in Waterfall.Booleans  -- means that we can use them in typeclass instances without resorting to orphans  toBoolean :: (Ptr TopoDS.Shape -> Ptr TopoDS.Shape -> Acquire (Ptr TopoDS.Shape)) -> Solid -> Solid -> Solid-toBoolean f (Solid runA) (Solid runB) = Solid $ do-    a <- runA-    b <- runB+toBoolean f (Solid ptrA) (Solid ptrB) = Solid . unsafeFromAcquire $ do+    a <- toAcquire ptrA+    b <- toAcquire ptrB     f a b  -- | Take the sum of two solids
src/Waterfall/Offset.hs view
@@ -2,7 +2,7 @@ ( offset ) where  -import Waterfall.Internal.Solid (Solid (..))+import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire) import qualified OpenCascade.BRepOffsetAPI.MakeOffsetShape as MakeOffsetShape import Control.Monad.IO.Class (liftIO) import OpenCascade.Inheritance (SubTypeOf(upcast), unsafeDowncast)@@ -20,14 +20,12 @@     -> Double       -- ^ Tolerance, this can be relatively small     -> Solid        -- ^ the `Solid` to offset      -> Solid-offset value tolerance (Solid run)-    | nearZero value = Solid run+offset value tolerance solid+    | nearZero value = solid     | otherwise = -  Solid $ do--+  solidFromAcquire $ do     builder <- MakeOffsetShape.new-    s <- run +    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)
src/Waterfall/Path.hs view
@@ -28,7 +28,7 @@  -- | convert a `Path2D` into a `Path` on the \( xy \) plane (with \( z = 0 \) ) fromPath2D :: Path2D -> Path-fromPath2D (Path2D run) = Path run+fromPath2D (Path2D raw) = Path raw  -- $reexports --
src/Waterfall/Path/Common.hs view
@@ -28,6 +28,7 @@ import Foreign.Ptr import Waterfall.Internal.Path (Path (..)) import Waterfall.TwoD.Internal.Path2D (Path2D (..))+import Waterfall.Internal.Finalizers (unsafeFromAcquire) import Control.Arrow (second) import Data.Foldable (foldl', traverse_) import qualified OpenCascade.BRepBuilderAPI.MakeWire as MakeWire@@ -162,12 +163,12 @@  instance AnyPath (V3 Double) Path where     fromWire :: Acquire (Ptr TopoDS.Wire) -> Path-    fromWire = Path+    fromWire = Path . unsafeFromAcquire     pointToGPPnt :: Proxy Path -> V3 Double -> Acquire (Ptr GP.Pnt)     pointToGPPnt _ (V3 x y z) = GP.Pnt.new x y z   instance AnyPath (V2 Double) Path2D where     fromWire :: Acquire (Ptr TopoDS.Wire) -> Path2D-    fromWire = Path2D+    fromWire = Path2D . unsafeFromAcquire     pointToGPPnt :: Proxy Path2D -> V2 Double -> Acquire (Ptr GP.Pnt)     pointToGPPnt _ (V2 x y) = GP.Pnt.new x y 0
src/Waterfall/Revolution.hs view
@@ -2,8 +2,9 @@ ( revolution ) where -import Waterfall.Internal.Solid (Solid (..))+import Waterfall.Internal.Solid (Solid (..), solidFromAcquire) import Waterfall.TwoD.Internal.Path2D (Path2D (..))+import Waterfall.Internal.Finalizers (toAcquire) import qualified OpenCascade.BRepPrimAPI.MakeRevol as MakeRevol import qualified OpenCascade.BRepBuilderAPI.MakeSolid as MakeSolid import qualified OpenCascade.BRepBuilderAPI.MakeShape as MakeShape@@ -19,8 +20,8 @@ --  -- The resulting `Solid` is rotated such that the axis of revolution is the z axis. revolution :: Path2D -> Solid-revolution (Path2D run) = rotate (unit _x) (pi/2) . Solid $ do-    p <- run+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)
src/Waterfall/Solids.hs view
@@ -9,27 +9,42 @@ , centeredCylinder , unitCone , prism+, volume+, centerOfMass+, momentOfInertia ) where  -import Waterfall.Internal.Solid(Solid(..), nowhere)-import Waterfall.TwoD.Internal.Shape (runShape)+import Waterfall.Internal.Solid (Solid (..), solidFromAcquire, acquireSolid, nowhere)+import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)+import Waterfall.TwoD.Internal.Shape (rawShape)+import Waterfall.Internal.FromOpenCascade (gpPntToV3) import Waterfall.Transforms (translate) import qualified Waterfall.TwoD.Shape as TwoD.Shape import qualified OpenCascade.BRepPrimAPI.MakeBox as MakeBox import qualified OpenCascade.BRepPrimAPI.MakeSphere as MakeSphere import qualified OpenCascade.BRepPrimAPI.MakeCylinder as MakeCylinder import qualified OpenCascade.BRepPrimAPI.MakeCone as MakeCone+import qualified OpenCascade.GProp.GProps as GProps+import qualified OpenCascade.BRepGProp as BRepGProp import qualified OpenCascade.GP as GP-import Linear (V3 (..), unit, _z, (^*))+import Control.Lens ((^.))+import Linear (V3 (..), unit, _x, _y, _z, (^*)) import qualified OpenCascade.GP.Pnt as GP.Pnt import qualified OpenCascade.GP.Vec as GP.Vec+import qualified OpenCascade.GP.Dir as GP.Dir+import qualified OpenCascade.GP.Ax1 as GP.Ax1 import qualified OpenCascade.BRepPrimAPI.MakePrism as MakePrism import qualified OpenCascade.Inheritance as Inheritance +import Control.Monad.IO.Class (liftIO)+import Control.Monad ((<=<))+import Foreign.Ptr (Ptr)+import Data.Acquire (Acquire)+ -- | A cube with side lengths of 1, one vertex on the origin, another on \( (1, 1, 1) \) unitCube :: Solid-unitCube = Solid $ do+unitCube = solidFromAcquire $ do     a <- GP.origin     b <- GP.Pnt.new 1 1 1     builder <- MakeBox.fromPnts a b@@ -37,7 +52,7 @@  -- | A cube with side lengths of 1, centered on the origin centeredCube :: Solid-centeredCube = Solid $ do+centeredCube = solidFromAcquire $ do     a <- GP.Pnt.new (-1/2) (-1/2) (-1/2)     b <- GP.Pnt.new (1/2) (1/2) (1/2)     builder <- MakeBox.fromPnts a b@@ -45,21 +60,22 @@  -- | A cuboid, one vertex on the origin, another on a given point box :: V3 Double -> Solid-box (V3 x y z) = Solid $ do+box (V3 x y z) = solidFromAcquire $ do     a <- GP.origin     b <- GP.Pnt.new x y z     builder <- MakeBox.fromPnts a b     Inheritance.upcast <$> MakeBox.solid builder+      -- | A sphere with radius of 1, centered on the origin unitSphere :: Solid-unitSphere = Solid $ Inheritance.upcast <$> MakeSphere.fromRadius 1+unitSphere = solidFromAcquire $ Inheritance.upcast <$> MakeSphere.fromRadius 1  -- | A cylinder with radius 1, length 1, -- one of it's circular faces centered on the origin, -- the other centered on \( (0, 0, 1) \) unitCylinder :: Solid-unitCylinder = Solid $ Inheritance.upcast <$> MakeCylinder.fromRadiusAndHeight 1 1+unitCylinder = solidFromAcquire $ Inheritance.upcast <$> MakeCylinder.fromRadiusAndHeight 1 1  -- | A cylinder with radius 1, length 1, -- centered on the origin,@@ -68,19 +84,42 @@  -- | A cone  -- With a point at the origin --- and a circular face with Radius 1, centered on \( (0, 1, 1) \)+-- and a circular face with Radius 1, centered on \( (0, 0, 1) \) unitCone :: Solid-unitCone = Solid $ Inheritance.upcast <$> MakeCone.fromTwoRadiiAndHeight 0 1 1+unitCone = solidFromAcquire $ Inheritance.upcast <$> MakeCone.fromTwoRadiiAndHeight 0 1 1  -- | Extruded a 2D face into a prism with a given length \(len\). -- -- One of the prisms faces lies on the plane \(z = 0\), -- the other on the plane \(z = len\). prism :: Double -> TwoD.Shape.Shape -> Solid-prism len face = Solid $ do-    p <- runShape face+prism len face = solidFromAcquire $ do+    p <- toAcquire . rawShape $ face     v <- GP.Vec.new 0 0 len     MakePrism.fromVec p v True True +gPropQuery :: (Ptr GProps.GProps -> Acquire a) -> Solid -> a+gPropQuery f s = unsafeFromAcquire $ do+    solid <- acquireSolid s+    gProp <- GProps.new+    liftIO $ BRepGProp.volumeProperties solid gProp False False False+    f gProp +-- | Volume of the Solid+volume :: Solid -> Double+volume = gPropQuery (liftIO . GProps.mass) +-- | Center Of Mass of the Solid+centerOfMass :: Solid -> V3 Double +centerOfMass = gPropQuery ((liftIO . gpPntToV3) <=< GProps.centreOfMass)++-- | Moment of Inertia of the Solid around a particular point and axis+momentOfInertia :: V3 Double -- ^ Point on the Axis of the Moment+    -> V3 Double -- ^ Direction of the Axis of the Moment +    -> Solid+    -> Double +momentOfInertia center axis = gPropQuery $ \gprop -> do+    pnt <- GP.Pnt.new (center ^. _x) (center ^. _y) (center ^. _z)+    dir <- GP.Dir.new (axis ^. _x) (axis ^. _y) (axis ^. _z)+    ax1 <- GP.Ax1.new pnt dir+    liftIO $ GProps.momentOfInertia gprop ax1
src/Waterfall/Sweep.hs view
@@ -2,9 +2,10 @@ ( sweep ) where -import Waterfall.Internal.Solid (Solid (..))+import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire) import Waterfall.Internal.Path (Path (..)) import Waterfall.Internal.Edges (wireTangent, wireEndpoints)+import Waterfall.Internal.Finalizers (toAcquire) import Waterfall.Transforms (rotate, translate) import Waterfall.TwoD.Internal.Shape (Shape (..)) import qualified OpenCascade.BRepOffsetAPI.MakePipe as MakePipe@@ -25,16 +26,16 @@             else                 let axis = if nearZero (vn + z) then unit _x else z `cross` vn                     angle = acos (vn `dot` z)-                in runSolid . rotate axis angle . Solid . pure $ face +                in acquireSolid . rotate axis angle . solidFromAcquire . pure $ face   positionFace :: V3 Double -> Ptr TopoDS.Shape -> Acquire (Ptr TopoDS.Shape)-positionFace p = runSolid . translate p . Solid . pure+positionFace p = acquireSolid . translate p . solidFromAcquire . pure  -- | Sweep a 2D `Shape` along a `Path`, constructing a `Solid` sweep :: Path -> Shape -> Solid-sweep (Path runThePath) (Shape runTheShape) = Solid $ do-    path <- runThePath-    shape <- runTheShape+sweep (Path theRawPath) (Shape theRawShape) = solidFromAcquire $ do+    path <- toAcquire theRawPath+    shape <- toAcquire theRawShape     tangent <- liftIO $ wireTangent path     (start,_)  <- liftIO $ wireEndpoints path     adjustedFace <- positionFace start =<< rotateFace tangent shape
src/Waterfall/Transforms.hs view
@@ -8,7 +8,8 @@ , translate , mirror ) where-import Waterfall.Internal.Solid (Solid(..))+import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire)+import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)  import Linear.V3 (V3 (..)) import Linear ((*^), normalize, dot ) import qualified Linear.Quaternion as Quaternion@@ -43,28 +44,28 @@   fromTrsfSolid :: Acquire (Ptr GP.Trsf) -> Solid -> Solid-fromTrsfSolid mkTrsf (Solid run) = Solid $ do -    solid <- run+fromTrsfSolid mkTrsf s = solidFromAcquire $ do +    solid <- acquireSolid s     trsf <- mkTrsf      BRepBuilderAPI.Transform.transform solid trsf True    fromGTrsfSolid :: Acquire (Ptr GP.GTrsf) -> Solid -> Solid-fromGTrsfSolid mkTrsf (Solid run) = Solid $ do -    solid <- run+fromGTrsfSolid mkTrsf s = solidFromAcquire $ do +    solid <- acquireSolid s     trsf <- mkTrsf      BRepBuilderAPI.GTransform.gtransform solid trsf True    fromTrsfPath :: Acquire (Ptr GP.Trsf) -> Path -> Path-fromTrsfPath mkTrsf (Path run) = Path $ do -    path <- run+fromTrsfPath mkTrsf (Path p) = Path . unsafeFromAcquire $ do +    path <- toAcquire p     trsf <- mkTrsf      (liftIO . unsafeDowncast) =<< BRepBuilderAPI.Transform.transform (upcast path) trsf True   fromGTrsfPath :: Acquire (Ptr GP.GTrsf) -> Path -> Path-fromGTrsfPath mkTrsf (Path run) = Path $ do -    path <- run+fromGTrsfPath mkTrsf (Path p) = Path . unsafeFromAcquire $ do +    path <- toAcquire p     trsf <- mkTrsf      (liftIO . unsafeDowncast) =<< BRepBuilderAPI.GTransform.gtransform (upcast path) trsf True
src/Waterfall/TwoD/Internal/Path2D.hs view
@@ -4,7 +4,7 @@ ) where  import Data.Foldable (traverse_, toList)-import Data.Acquire+import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire) import Control.Monad ((<=<)) import Control.Monad.IO.Class (liftIO) import qualified OpenCascade.TopoDS as TopoDS@@ -18,12 +18,12 @@ -- -- 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 { runPath :: Acquire (Ptr TopoDS.Wire) }+newtype Path2D = Path2D { rawPath :: Ptr TopoDS.Wire }  joinPaths :: [Path2D] -> Path2D-joinPaths paths = Path2D $ do+joinPaths paths = Path2D . unsafeFromAcquire $ do     builder <- MakeWire.new-    traverse_ (liftIO . MakeWire.addWire builder <=< runPath) paths+    traverse_ (liftIO . MakeWire.addWire builder <=< toAcquire . rawPath) paths     MakeWire.wire builder  -- | The Semigroup for `Path2D` attempts to join two paths that share a common endpoint.
src/Waterfall/TwoD/Internal/Shape.hs view
@@ -3,7 +3,6 @@ ) where  import qualified OpenCascade.TopoDS as TopoDS-import Data.Acquire import Foreign.Ptr  -- | A Region in 2D Space @@ -17,4 +16,4 @@ -- Please feel free to report a bug if you're able to construct a `Shape` -- which does not lie on this plane (without using Internal functions). -- Or which is not either a `TopoDS.Face`, or a composite of faces.-newtype Shape = Shape { runShape :: Acquire (Ptr TopoDS.Shape) }+newtype Shape = Shape { rawShape :: Ptr TopoDS.Shape }
src/Waterfall/TwoD/Path2D.hs view
@@ -27,6 +27,7 @@  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)@@ -78,19 +79,19 @@ -- -- This can be used to construct paths with rotational symmetry, such as regular polygons, or gears. repeatLooping :: Path2D -> Path2D-repeatLooping p = Path2D $ do-    path <- runPath p +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 -    runPath $ mconcat [rotate2D (negate (fromIntegral n) * a) p | n <- [0..times]]+    toAcquire . rawPath . mconcat $ [rotate2D (negate (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 $ do-    path <- runPath p+closeLoop p = Path2D . unsafeFromAcquire $ do+    path <- toAcquire . rawPath $ p     (s, e) <- liftIO . Internal.Edges.wireEndpoints $ path-    runPath $ mconcat [p, line (e ^. _xy)  (s ^. _xy)]+    toAcquire .rawPath . mconcat $ [p, line (e ^. _xy)  (s ^. _xy)]  -- $reexports --
src/Waterfall/TwoD/Shape.hs view
@@ -9,6 +9,7 @@ import Waterfall.TwoD.Internal.Shape (Shape (..)) import Waterfall.TwoD.Internal.Path2D (Path2D (..)) import Waterfall.TwoD.Transforms (translate2D)+import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire) import qualified OpenCascade.BRepBuilderAPI.MakeFace as MakeFace import OpenCascade.Inheritance (upcast) import Linear (unit, _x, _y, zero, V2 (..))@@ -16,8 +17,8 @@  -- | Construct a 2D Shape from a closed path  fromPath :: Path2D -> Shape-fromPath (Path2D run)= Shape $ do-    p <- run+fromPath (Path2D r)= Shape . unsafeFromAcquire  $ do+    p <- toAcquire r     upcast <$> (MakeFace.face =<< MakeFace.fromWire p False)  -- | Circle with radius 1, centered on the origin
src/Waterfall/TwoD/Text.hs view
@@ -7,6 +7,7 @@ ) where  import qualified Waterfall.TwoD.Internal.Shape as Shape+import Waterfall.Internal.Finalizers (toAcquire, fromAcquire, unsafeFromAcquire) import qualified OpenCascade.GP.Ax3 as GP.Ax3 import qualified OpenCascade.Font.BRepFont as BRepFont import qualified OpenCascade.Font.BRepTextBuilder as BRepTextBuilder@@ -14,32 +15,34 @@ import qualified OpenCascade.Graphic3D.HorizontalTextAlignment as HTA import Foreign.Ptr  import Control.Monad (unless)-import Control.Monad.IO.Class (liftIO) import OpenCascade.Font.FontAspect (FontAspect (..)) -newtype Font = Font {initFont :: Ptr BRepFont.BRepFont -> IO ()}+newtype Font = Font { rawFont :: Ptr BRepFont.BRepFont }  -- | create a font from a filepath and a font size -fontFromPath :: FilePath -> Double -> Font -fontFromPath fontpath size = Font $ \font -> do-    fontOk <- BRepFont.initFromPathAndSize font fontpath size+fontFromPath :: FilePath -> Double -> IO Font +fontFromPath fontpath size = do+    bRepFont <- fromAcquire $ BRepFont.new+    fontOk <- BRepFont.initFromPathAndSize bRepFont fontpath size     unless (fontOk) $ error ("Unable to initialize font from filepath: " <> fontpath)+    return $ Font bRepFont  -- | Create a font from a system font name, aspect, and size-fontFromSystem :: String -> FontAspect -> Double -> Font -fontFromSystem name aspect size = Font $ \font -> do-    fontOk <- BRepFont.initFromNameAspectAndSize font name aspect size+fontFromSystem :: String -> FontAspect -> Double -> IO Font +fontFromSystem name aspect size = do+    bRepFont <- fromAcquire $ BRepFont.new+    fontOk <- BRepFont.initFromNameAspectAndSize bRepFont name aspect size     unless (fontOk) $ error ("Unable to initialize system font with name: " <> name <> ", and aspect" <> show aspect)+    return $ Font bRepFont  -- | Render text, using the font from the provided filepath, at a given size. -- -- The IO of actually loading the font/checking the file exists is defered  -- until the Shape is actually used text :: Font -> String -> Shape.Shape -text font content = Shape.Shape $ do+text font content = Shape.Shape . unsafeFromAcquire $ do     axis <- GP.Ax3.new-    brepfont <- BRepFont.new-    liftIO $ initFont font brepfont+    bRepFont <- toAcquire . rawFont $ font     builder <- BRepTextBuilder.new-    BRepTextBuilder.perform builder brepfont content axis HTA.Center VTA.Center+    BRepTextBuilder.perform builder bRepFont content axis HTA.Center VTA.Center
src/Waterfall/TwoD/Transforms.hs view
@@ -10,6 +10,7 @@ ) where  import Waterfall.TwoD.Internal.Path2D (Path2D (..))+import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire) import Linear.V2 (V2 (..)) import Linear ((*^), normalize, dot) import qualified OpenCascade.GP.Trsf as GP.Trsf@@ -44,27 +45,27 @@     mirror2D :: V2 Double -> a -> a  fromTrsfPath :: Acquire (Ptr GP.Trsf) -> Path2D -> Path2D-fromTrsfPath mkTrsf (Path2D run) = Path2D $ do -    path <- run+fromTrsfPath mkTrsf (Path2D p) = Path2D . unsafeFromAcquire $ do +    path <- toAcquire p     trsf <- mkTrsf      (liftIO . unsafeDowncast) =<< BRepBuilderAPI.Transform.transform (upcast path) trsf True   fromTrsfShape :: Acquire (Ptr GP.Trsf) -> Shape -> Shape-fromTrsfShape mkTrsf (Shape run) = Shape $ do -    shape <- run+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 run) = Path2D $ do -    path <- run+fromGTrsfPath mkTrsf (Path2D p) = Path2D . unsafeFromAcquire  $ do +    path <- toAcquire p     trsf <- mkTrsf      (liftIO . unsafeDowncast) =<< BRepBuilderAPI.GTransform.gtransform (upcast path) trsf True   fromGTrsfShape :: Acquire (Ptr GP.GTrsf) -> Shape -> Shape-fromGTrsfShape mkTrsf (Shape run) = Shape $ do -    shape <- run+fromGTrsfShape mkTrsf (Shape theRawShape) = Shape . unsafeFromAcquire $ do +    shape <- toAcquire theRawShape      trsf <- mkTrsf      BRepBuilderAPI.GTransform.gtransform shape trsf True
waterfall-cad.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           waterfall-cad-version:        0.1.2.2+version:        0.2.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@@ -31,8 +31,12 @@       Waterfall       Waterfall.Booleans       Waterfall.Booleans.Operators+      Waterfall.BoundingBox.AxisAligned+      Waterfall.BoundingBox.Oriented       Waterfall.Fillet       Waterfall.Internal.Edges+      Waterfall.Internal.Finalizers+      Waterfall.Internal.FromOpenCascade       Waterfall.Internal.Path       Waterfall.Internal.Solid       Waterfall.IO@@ -53,12 +57,13 @@       Paths_waterfall_cad   hs-source-dirs:       src-  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  ghc-options: -Wall -Werror=compat -Werror=identities -Werror=incomplete-record-updates -Werror=incomplete-uni-patterns -Werror=missing-home-modules -Werror=missing-export-lists -Werror=partial-fields -Werror=redundant-constraints -optc -Werror-implicit-function-declaration   build-depends:       base >=4.7 && <5     , lattices >=2.0 && <3     , lens ==5.*     , linear >=1.21 && <2-    , opencascade-hs >=0.1.2.2 && <0.2+    , opencascade-hs >=0.2.0.0 && <0.3+    , primitive >=0.7 && <0.10     , resourcet >=1.2 && <1.4   default-language: Haskell2010