diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,11 +9,24 @@ ## Unreleased +## 0.2.2.0 + +### Added +- New functions in `Waterfall.IO` + - Support for reading (as well as writing) all file formats + - `readSTL`, `readSTEP`, `readGLTF`, `readGLB`, `readOBJ` + - (Wavefront) OBJ support (`writeOBJ`) + - Convenience methods `readSolid` and `writeSolid` inferring the format from the file extension + +### Changed + +- Make error handling for actions in `Waterfall.Text` throw a `WaterfallIOException` on failure ## 0.2.1.0 ### Added -- graphicsLibraryTransmissionFormat support: `writeGLTF` and `writeGLB` in `Waterfall.IO` +- GLTF (graphics library transmission format) support: `writeGLTF` and `writeGLB` in `Waterfall.IO` +- obj file format support `writeOBJ` in `Waterfall.IO` ## 0.2.0.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ # Waterfall CAD +![Waterfall CAD](https://raw.githubusercontent.com/joe-warren/opencascade-hs/main/images/logo/waterfall-cad-logo-name.svg) + Waterfall CAD is a declarative CAD/Solid Modeling library. This uses [opencascade-hs](https://hackage.haskell.org/package/opencascade-hs) as the kernel, but provides a "more functional" API over it. diff --git a/src/Waterfall.hs b/src/Waterfall.hs --- a/src/Waterfall.hs +++ b/src/Waterfall.hs @@ -1,21 +1,53 @@ +{-| +Module: Waterfall + +This module simply re-exports everything from the various modules +that make up the waterfall-cad package. +-} module Waterfall -( module Waterfall.Booleans +( +-- | `Solid` is the main data type in the Waterfall-CAD API, +-- The "Waterfall.Solids" module is the easiest way to construct +-- instances of `Solid`. + module Waterfall.Solids +-- | The functions in this module can be used to transform `Solid`s. +, module Waterfall.Transforms +-- | `Solid`'s can be combined together with +-- [Constructive Solid Geometry](https://en.wikipedia.org/wiki/Constructive_solid_geometry). +, module Waterfall.Booleans , module Waterfall.Booleans.Operators +-- | Once you've generated a `Solid`, +-- the functions in `Waterfall.IO` can be used to save it. +-- +-- The `Waterfall.IO` module also supports reading `Solid`s from a variety of file formats. +, module Waterfall.IO +-- | Calculating Axis Aligned Bounding Boxes from a `Solid`. , module Waterfall.BoundingBox.AxisAligned +-- | Calculating Oriented Bounding Boxes from a `Solid`. , module Waterfall.BoundingBox.Oriented +-- | This module deals with adding rounds\/fillets\/bevels to a `Solid`. , module Waterfall.Fillet -, module Waterfall.IO +-- | This module deals with offsetting a `Solid`: either shrinking/expanding it. , module Waterfall.Offset -, module Waterfall.Path.Common +-- | Paths in 3D space. , module Waterfall.Path -, module Waterfall.Revolution -, module Waterfall.Solids +-- | Two Dimensional Shapes. +, module Waterfall.TwoD.Shape +-- | Sweep a 2D `Shape` along a `Path`, constructing a `Solid`. , module Waterfall.Sweep -, module Waterfall.Transforms +-- | Construct a `Solid` of revolution from a `Path2D`. +, module Waterfall.Revolution +-- | Transforms for data types that exist in Two Dimensional space, like `Shape` and `Path2D`. , module Waterfall.TwoD.Transforms +-- | Paths in 2D space, can be built up into a `Shape`. , module Waterfall.TwoD.Path2D -, module Waterfall.TwoD.Shape +-- | Create a `Shape` from text, rendered using a specific `Font`. , module Waterfall.TwoD.Text +-- | Paths in 2D / 3D space. +-- +-- 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 )where import Waterfall.Booleans diff --git a/src/Waterfall/IO.hs b/src/Waterfall/IO.hs --- a/src/Waterfall/IO.hs +++ b/src/Waterfall/IO.hs @@ -1,46 +1,148 @@ module Waterfall.IO -( writeSTL +( WaterfallIOException (..) +, WaterfallIOExceptionCause (..) + -- * Solid Writers +, writeSolid +, writeSTL +, writeAsciiSTL , writeSTEP , writeGLTF , writeGLB +, writeOBJ + -- * Solid Readers + -- + -- | Load a `Waterfall.Solid` from a file + -- + -- At present, the "read*" functions do slightly less validation on the loaded solid + -- than they arguably should + -- and may succeed when reading solids that may generate invalid geometry when processed +, readSolid +, readSTL +, readSTEP +, readGLTF +, readGLB +, readOBJ ) where import Waterfall.Internal.Solid (Solid(..)) +import qualified Waterfall.Internal.Remesh as Remesh import qualified OpenCascade.BRepMesh.IncrementalMesh as BRepMesh.IncrementalMesh import qualified OpenCascade.StlAPI.Writer as StlWriter +import qualified OpenCascade.StlAPI.Reader as StlReader import qualified OpenCascade.STEPControl.Writer as StepWriter import qualified OpenCascade.STEPControl.StepModelType as StepModelType +import qualified OpenCascade.STEPControl.Reader as STEPReader +import qualified OpenCascade.XSControl.Reader as XSControl.Reader +import qualified OpenCascade.IFSelect.ReturnStatus as IFSelect.ReturnStatus import qualified OpenCascade.TDocStd.Document as TDocStd.Document +import qualified OpenCascade.Message.Types as Message import qualified OpenCascade.Message.ProgressRange as Message.ProgressRange import qualified OpenCascade.TColStd.IndexedDataMapOfStringString as TColStd.IndexedDataMapOfStringString import qualified OpenCascade.RWGltf.CafWriter as RWGltf.CafWriter +import qualified OpenCascade.RWGltf.CafReader as RWGltf.CafReader +import qualified OpenCascade.RWObj.CafWriter as RWObj.CafWriter +import qualified OpenCascade.RWObj.CafReader as RWObj.CafReader +import qualified OpenCascade.RWMesh.Types as RWMesh +import qualified OpenCascade.RWMesh.CafReader as RWMesh.CafReader +import qualified OpenCascade.TDocStd.Types as TDocStd +import qualified OpenCascade.TColStd.Types as TColStd import qualified OpenCascade.XCAFDoc.DocumentTool as XCafDoc.DocumentTool import qualified OpenCascade.XCAFDoc.ShapeTool as XCafDoc.ShapeTool +import qualified OpenCascade.TopoDS.Types as TopoDS +import qualified OpenCascade.TopoDS.Shape as TopoDS.Shape +import OpenCascade.Handle (Handle) +import OpenCascade.Inheritance (upcast) import Control.Monad.IO.Class (liftIO) -import Control.Monad (void, unless) -import System.IO (hPutStrLn, stderr) -import Waterfall.Internal.Finalizers (toAcquire) -import Data.Acquire +import Control.Monad (unless, when) +import Waterfall.Internal.Finalizers (toAcquire, fromAcquire) +import Data.Acquire ( Acquire, withAcquire ) +import Foreign.Ptr (Ptr) +import Data.Char (toLower) +import System.FilePath (takeExtension) +import Control.Exception (Exception, throwIO) --- | Write a `Solid` to a (binary) STL file at a given path +-- | The type of exceptions thrown by IO actions defined in `Waterfall.IO` +data WaterfallIOException = + WaterfallIOException + { ioExceptionCause :: WaterfallIOExceptionCause + , ioExceptionFilePath :: FilePath + } + deriving Show + +instance Exception WaterfallIOException + +-- | Reason for an IO action to have failed +data WaterfallIOExceptionCause = + -- | Something went wrong when accessing a file, + -- eg. a write to a file path that is unreachable, + -- or a read to a file in the wrong format + FileError + -- | The contents of a file could not be converted into a `Waterfall.Solid` + -- e.g the file did not contain a solid object + | BadGeometryError + -- | The `readSolid`/`writeSolid` functions could not infer the correct file format from a filepath + | UnrecognizedFormatError + deriving (Show, Eq) + + +extensionToFormats :: String -> Maybe (Double -> FilePath -> Solid -> IO(), FilePath -> IO Solid) +extensionToFormats s = + let ext = fmap toLower . takeExtension $ s + in case ext of + ".stl" -> Just (writeSTL, readSTL) + ".step" -> Just (const writeSTEP, readSTEP) + ".gltf" -> Just (writeGLTF, readGLTF) + ".glb" -> Just (writeGLB, readGLB) + ".obj" -> Just (writeOBJ, readOBJ) + _ -> Nothing + +-- | Write a `Solid` to a file, work out the format from the file extension +-- +-- Errors if passed a filename with an unrecognized extension -- -- Because BRep representations of objects can store arbitrary precision curves, --- but STL files store triangulated surfaces, +-- but some of the supported file formats store triangulated surfaces, -- this function takes a "deflection" argument used to discretize curves. -- -- The deflection is the maximum allowable distance between a curve and the generated triangulation. -writeSTL :: Double -> FilePath -> Solid -> IO () -writeSTL linDeflection filepath (Solid ptr) = (`withAcquire` pure) $ do +writeSolid :: Double -> FilePath -> Solid -> IO () +writeSolid res filepath = + case extensionToFormats filepath of + Just (writer, _) -> writer res filepath + Nothing -> const $ throwIO (WaterfallIOException UnrecognizedFormatError filepath) + +writeSTLAsciiOrBinary :: Bool -> Double -> FilePath -> Solid -> IO () +writeSTLAsciiOrBinary asciiMode linDeflection filepath (Solid ptr) = (`withAcquire` pure) $ do s <- toAcquire ptr mesh <- BRepMesh.IncrementalMesh.fromShapeAndLinDeflection s linDeflection liftIO $ BRepMesh.IncrementalMesh.perform mesh writer <- StlWriter.new liftIO $ do - StlWriter.setAsciiMode writer False + StlWriter.setAsciiMode writer asciiMode res <- StlWriter.write writer s filepath - unless res (hPutStrLn stderr ("failed to write " <> filepath)) + unless res (throwIO (WaterfallIOException FileError filepath)) return () +-- | Write a `Solid` to a (binary) STL file at a given path +-- +-- Because BRep representations of objects can store arbitrary precision curves, +-- but STL files store triangulated surfaces, +-- this function takes a "deflection" argument used to discretize curves. +-- +-- The deflection is the maximum allowable distance between a curve and the generated triangulation. +writeSTL :: Double -> FilePath -> Solid -> IO () +writeSTL = writeSTLAsciiOrBinary False + +-- | Write a `Solid` to an Ascii STL file at a given path +-- +-- Because BRep representations of objects can store arbitrary precision curves, +-- but STL files store triangulated surfaces, +-- this function takes a "deflection" argument used to discretize curves. +-- +-- The deflection is the maximum allowable distance between a curve and the generated triangulation. +writeAsciiSTL :: Double -> FilePath -> Solid -> IO () +writeAsciiSTL = writeSTLAsciiOrBinary True + -- | Write a `Solid` to a STEP file at a given path -- -- STEP files can be imported by [FreeCAD](https://www.freecad.org/) @@ -48,11 +150,13 @@ 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 + resTransfer <- liftIO $ StepWriter.transfer writer s StepModelType.Asls True + unless (resTransfer == IFSelect.ReturnStatus.Done) (liftIO . throwIO $ WaterfallIOException BadGeometryError filepath) + resWrite <- liftIO $ StepWriter.write writer filepath + unless (resWrite == IFSelect.ReturnStatus.Done) (liftIO . throwIO $ WaterfallIOException FileError filepath) -writeGLTFOrGLB :: Bool -> Double -> FilePath -> Solid -> IO () -writeGLTFOrGLB binary linDeflection filepath (Solid ptr) = (`withAcquire` pure) $ do +cafWriter :: (FilePath -> Ptr (Handle TDocStd.Document) -> Ptr TColStd.IndexedDataMapOfStringString -> Ptr Message.ProgressRange -> Acquire ()) -> Double -> FilePath -> Solid-> IO () +cafWriter write linDeflection filepath (Solid ptr) = (`withAcquire` pure) $ do s <- toAcquire ptr mesh <- BRepMesh.IncrementalMesh.fromShapeAndLinDeflection s linDeflection liftIO $ BRepMesh.IncrementalMesh.perform mesh @@ -62,19 +166,124 @@ _ <- XCafDoc.ShapeTool.addShape shapeTool s True True meta <- TColStd.IndexedDataMapOfStringString.new progress <- Message.ProgressRange.new - writer <- RWGltf.CafWriter.new filepath binary - liftIO $ RWGltf.CafWriter.perform writer doc meta progress - return () + write filepath doc meta progress +writeGLTFOrGLB :: Bool -> Double -> FilePath -> Solid -> IO () +writeGLTFOrGLB binary = + let write filepath doc meta progress = do + writer <- RWGltf.CafWriter.new filepath binary + liftIO $ RWGltf.CafWriter.perform writer doc meta progress + in cafWriter write + -- | Write a `Solid` to a glTF file at a given path -- -- glTF, or Graphics Library Transmission Format is a JSON based format -- used for three-dimensional scenes and models +-- +-- Because BRep representations of objects can store arbitrary precision curves, +-- but glTF files store triangulated surfaces, +-- this function takes a "deflection" argument used to discretize curves. +-- +-- The deflection is the maximum allowable distance between a curve and the generated triangulation. writeGLTF :: Double -> FilePath -> Solid -> IO () writeGLTF = writeGLTFOrGLB False -- | Write a `Solid` to a glb file at a given path -- -- glb is the binary variant of the glTF file format +-- +-- Because BRep representations of objects can store arbitrary precision curves, +-- but glTF files store triangulated surfaces, +-- this function takes a "deflection" argument used to discretize curves. +-- +-- The deflection is the maximum allowable distance between a curve and the generated triangulation. writeGLB :: Double -> FilePath -> Solid -> IO () writeGLB = writeGLTFOrGLB True + +-- | Write a `Solid` to an obj file at a given path +-- +-- Wavefront OBJ is a simple ascii file format that stores geometric data. +-- +-- Because BRep representations of objects can store arbitrary precision curves, +-- but obj files store triangulated surfaces, +-- this function takes a "deflection" argument used to discretize curves. +-- +-- The deflection is the maximum allowable distance between a curve and the generated triangulation. +writeOBJ :: Double -> FilePath -> Solid -> IO () +writeOBJ = + let write filepath doc meta progress = do + writer <- RWObj.CafWriter.new filepath + liftIO $ RWObj.CafWriter.perform writer doc meta progress + in cafWriter write + +-- | Read a `Solid` from a file at a given path +-- +-- Throws an error if loading fails, or if it's unable to work out +-- the intended file format from the path +readSolid :: FilePath -> IO Solid +readSolid filepath = + case extensionToFormats filepath of + Nothing -> throwIO (WaterfallIOException UnrecognizedFormatError filepath) + Just (_, reader) -> reader filepath + +remeshOrThrow :: FilePath -> Ptr TopoDS.Shape -> Acquire (Ptr TopoDS.Shape) +remeshOrThrow filepath shape = do + remeshed <- Remesh.remesh shape + case remeshed of + Just solid -> pure solid + Nothing -> liftIO . throwIO $ WaterfallIOException BadGeometryError filepath + +-- | Read a `Solid` from an STL file at a given path +readSTL :: FilePath -> IO Solid +readSTL filepath = fmap Solid . fromAcquire $ do + shape <- TopoDS.Shape.new + reader <- StlReader.new + res <- liftIO $ StlReader.read reader shape filepath + unless res $ liftIO . throwIO $ WaterfallIOException FileError filepath + remeshOrThrow filepath shape + +-- | Read a `Solid` from a STEP file at a given path +readSTEP :: FilePath -> IO Solid +readSTEP filepath = fmap Solid . fromAcquire $ do + reader <- STEPReader.new + status <- liftIO $ XSControl.Reader.readFile (upcast reader) filepath + _ <- liftIO $ XSControl.Reader.transferRoots (upcast reader) + shape <- XSControl.Reader.oneShape (upcast reader) + unless (status == IFSelect.ReturnStatus.Done) (liftIO . throwIO $ WaterfallIOException FileError filepath) + shapeIsNull <- liftIO $ TopoDS.Shape.isNull shape + when shapeIsNull (liftIO . throwIO $ WaterfallIOException BadGeometryError filepath) + return shape + +cafReader :: Acquire (Ptr RWMesh.CafReader) -> FilePath -> IO Solid +cafReader mkReader filepath = fmap Solid . fromAcquire $ do + reader <- mkReader + doc <- TDocStd.Document.fromStorageFormat "" + progress <- Message.ProgressRange.new + _ <- liftIO $ RWMesh.CafReader.setDocument reader doc + res <- liftIO $ RWMesh.CafReader.perform reader filepath progress + unless res (liftIO . throwIO $ WaterfallIOException FileError filepath) + remeshOrThrow filepath =<< RWMesh.CafReader.singleShape reader + +-- | Read a `Solid` from a GLTF file at a given path +-- +-- This should support reading both the GLTF (json) and GLB (binary) formats +readGLTF :: FilePath -> IO Solid +readGLTF = cafReader $ do + reader <- RWGltf.CafReader.new + liftIO $ RWGltf.CafReader.setDoublePrecision reader True + liftIO $ RWMesh.CafReader.setFileLengthUnit (upcast reader) 1 + return (upcast reader) + +-- | Alias for `readGLTF` +readGLB :: FilePath -> IO Solid +readGLB = readGLTF + +-- | Read a `Solid` from an obj file at a given path +-- +-- This should support reading both the GLTF (json) and GLB (binary) formats +readOBJ :: FilePath -> IO Solid +readOBJ = cafReader $ do + reader <- RWObj.CafReader.new + liftIO $ RWObj.CafReader.setSinglePrecision reader False + liftIO $ RWMesh.CafReader.setFileLengthUnit (upcast reader) 1 + return (upcast reader) diff --git a/src/Waterfall/Internal/Finalizers.hs b/src/Waterfall/Internal/Finalizers.hs --- a/src/Waterfall/Internal/Finalizers.hs +++ b/src/Waterfall/Internal/Finalizers.hs @@ -10,6 +10,7 @@ module Waterfall.Internal.Finalizers ( unsafeFromAcquire , fromAcquire +, fromAcquireMay , toAcquire ) where @@ -30,6 +31,20 @@ release <- fromMaybe (pure ()) <$> unprotect releaseKey liftIO $ addFinalizer v release return v + + +-- | variant of `fromAcquire` which registers the finalizer on the _value_ in a `Maybe` +-- as opposed to the maybe 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 + (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' -- | 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. diff --git a/src/Waterfall/Internal/Remesh.hs b/src/Waterfall/Internal/Remesh.hs new file mode 100644 --- /dev/null +++ b/src/Waterfall/Internal/Remesh.hs @@ -0,0 +1,127 @@ +{-| +Module: Waterfall.Internal.Remesh + +This code exists because the opencascade GLTF loading code generates "weird" BReps + +The FreeCAD sourcecode describes this as follows: + +> The glTF reader creates a compound of faces that only contains the triangulation +> but not the underlying surfaces. This leads to faces without boundaries. +> The triangulation is used to create a valid shape. + +The practical result of this, seems to be that directly using an `OpenCascade.TopoDS.Shape` +loaded using `OpenCascade.RWGltf.CafReader` in most operations will lead to segmentation faults. + +However, we can safely access the Triangulation of the Shape, construct Polygons from this +and then use BReps derived from these Polygons. + +In this way, the `remesh` function produces a new Boundary Represenation from the Mesh of an `OpenCascade.TopoDS.Shape` + +-} +module Waterfall.Internal.Remesh +( remesh +) where + +import qualified OpenCascade.GP.Pnt as GP.Pnt +import qualified OpenCascade.TopoDS as TopoDS +import qualified OpenCascade.TopoDS.Shape as TopoDS.Shape +import qualified OpenCascade.TopoDS.Compound as TopoDS.Compound +import qualified OpenCascade.TopExp.Explorer as TopExp.Explorer +import qualified OpenCascade.TopAbs.ShapeEnum as ShapeEnum +import qualified OpenCascade.TopAbs.Orientation as TopAbs.Orientation +import qualified OpenCascade.BRepBuilderAPI.Sewing as BRepBuilderAPI.Sewing +import qualified OpenCascade.BRepBuilderAPI.MakePolygon as BRepBuilderAPI.MakePolygon +import qualified OpenCascade.BRepBuilderAPI.MakeFace as BRepBuilderAPI.MakeFace +import qualified OpenCascade.BRepBuilderAPI.MakeSolid as BRepBuilderAPI.MakeSolid +import qualified OpenCascade.BRepBuilderAPI.MakeShape as BRepBuilderAPI.MakeShape +import qualified OpenCascade.BRep.Tool as BRep.Tool +import qualified OpenCascade.BRepLib as BRepLib +import qualified OpenCascade.TopoDS.Builder as TopoDS.Builder +import qualified OpenCascade.BRepMesh.IncrementalMesh as BRepMesh.IncrementalMesh +import qualified OpenCascade.Poly.Triangulation as Poly.Triangulation +import qualified OpenCascade.Poly.Triangle as Poly.Triangle +import qualified OpenCascade.TopLoc.Location as TopLoc.Location +import OpenCascade.Inheritance (upcast, unsafeDowncast) +import Foreign.Ptr (Ptr) +import Data.Acquire (Acquire) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad (when, unless, forM_, (<=<)) + + +checkNonNull:: MonadIO m => Ptr TopoDS.Shape -> m (Maybe (Ptr TopoDS.Shape)) +checkNonNull shape = do + isNull <- liftIO . TopoDS.Shape.isNull $ shape + return $ if isNull + then Nothing + else Just shape + +remesh :: Ptr TopoDS.Shape -> Acquire (Maybe (Ptr TopoDS.Shape)) +remesh s = do + + let linDeflection = 0.01 + mesh <- BRepMesh.IncrementalMesh.fromShapeAndLinDeflection s linDeflection + liftIO $ BRepMesh.IncrementalMesh.perform mesh + + builder <- TopoDS.Builder.new + compound <- TopoDS.Compound.new + liftIO $ TopoDS.Builder.makeCompound builder compound + sewing <- BRepBuilderAPI.Sewing.new 1e-6 True True True False + explorer <- TopExp.Explorer.new s ShapeEnum.Face + + let actionForEachFace :: Acquire () + actionForEachFace = do + faceAsShape <- liftIO $ TopExp.Explorer.value explorer + faceAsFace <- liftIO . unsafeDowncast $ faceAsShape + loc <- TopLoc.Location.new + orientation <- liftIO $ TopoDS.Shape.orientation faceAsShape + trsf <- TopLoc.Location.toGPTrsf loc + triangulation <- BRep.Tool.triangulation faceAsFace loc + triCount <- liftIO $ Poly.Triangulation.nbTriangles triangulation + forM_ [1..triCount] $ \i -> do + triangle <- Poly.Triangulation.triangle triangulation i + let p = (`GP.Pnt.transformed` trsf) <=< Poly.Triangulation.node triangulation <=< liftIO . Poly.Triangle.value triangle + p1 <- p 1 + p2 <- p 2 + p3 <- p 3 + let pointsEqual a b = liftIO $ GP.Pnt.isEqual a b 0 + p12Coincident <- pointsEqual p1 p2 + p13Coincident <- pointsEqual p1 p3 + p23Coincident <- pointsEqual p2 p3 + let anyPointsCoincident = p12Coincident || p13Coincident || p23Coincident + unless anyPointsCoincident $ do + let makePolygon p1' p2' p3' = BRepBuilderAPI.MakePolygon.from3Pnts p1' p2' p3' True + polygon <- if orientation == TopAbs.Orientation.Reversed + then makePolygon p1 p3 p2 + else makePolygon p1 p2 p3 + polygonIsNull <- liftIO $ TopoDS.Shape.isNull (upcast polygon) + unless polygonIsNull $ do + makeFace <- BRepBuilderAPI.MakeFace.fromWire polygon False + newFace <- BRepBuilderAPI.MakeShape.shape (upcast makeFace) + faceIsNull <- liftIO $ TopoDS.Shape.isNull newFace + unless faceIsNull $ liftIO $ TopoDS.Builder.add builder (upcast compound) newFace + + let go = do + isMore <- liftIO $ TopExp.Explorer.more explorer + when isMore $ do + actionForEachFace + liftIO $ TopExp.Explorer.next explorer + go + go + liftIO $ BRepBuilderAPI.Sewing.load sewing (upcast compound) + liftIO . BRepBuilderAPI.Sewing.perform $ sewing + shape <- BRepBuilderAPI.Sewing.sewedShape sewing + makeSolid <- BRepBuilderAPI.MakeSolid.new + shapeAsShell <- liftIO $ unsafeDowncast shape + liftIO $ BRepBuilderAPI.MakeSolid.add makeSolid shapeAsShell + shapeAsSolid <- BRepBuilderAPI.MakeSolid.solid makeSolid + maybeNotNull <- checkNonNull (upcast shapeAsSolid) + case maybeNotNull of + Nothing -> return Nothing + Just _ -> do + orientable <- liftIO $ BRepLib.orientClosedSolid (shapeAsSolid) + if orientable + then return . Just . upcast $ shapeAsSolid + else return Nothing + + + diff --git a/src/Waterfall/Internal/Solid.hs b/src/Waterfall/Internal/Solid.hs --- a/src/Waterfall/Internal/Solid.hs +++ b/src/Waterfall/Internal/Solid.hs @@ -16,7 +16,6 @@ import Foreign.Ptr import Algebra.Lattice import Control.Monad.IO.Class (liftIO) -import Control.Monad (forM_) import qualified OpenCascade.TopoDS as TopoDS import qualified OpenCascade.TopoDS.Shape as TopoDS.Shape import qualified OpenCascade.BRepAlgoAPI.Fuse as Fuse @@ -46,8 +45,8 @@ -- | 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 ptr) = +debug :: Solid -> String +debug (Solid ptr) = let fshow :: Show a => IO a -> IO String fshow = fmap show @@ -65,14 +64,10 @@ , ("convex", fshow . TopoDS.Shape.convex) , ("nbChildren", fshow . TopoDS.Shape.nbChildren) ] - in Solid $ unsafeFromAcquire $ do + in unsafeFromAcquire $ do s <- toAcquire ptr - liftIO $ do - putStrLn name - forM_ actions $ \(actionName, value) -> do - putStrLn ("\t" <> actionName) - putStrLn . ("\t\t" <>) =<< value s - return s + liftIO $ (`foldMap` actions) $ \(actionName, value) -> + (return $ "\t" <> actionName <> "\t\t") <> value s <> (return "\n") {-- -- TODO: this does not work, need to fix diff --git a/src/Waterfall/Offset.hs b/src/Waterfall/Offset.hs --- a/src/Waterfall/Offset.hs +++ b/src/Waterfall/Offset.hs @@ -10,8 +10,28 @@ import qualified OpenCascade.BRepOffset.Mode as Mode import qualified OpenCascade.GeomAbs.JoinType as GeomAbs.JoinType import qualified OpenCascade.BRepBuilderAPI.MakeSolid as MakeSolid +import qualified OpenCascade.TopoDS.Types as TopoDS +import qualified OpenCascade.TopExp.Explorer as TopExp.Explorer +import qualified OpenCascade.TopAbs.ShapeEnum as TopAbs.ShapeEnum +import Control.Monad (when) +import Foreign.Ptr (Ptr) +import Data.Acquire (Acquire) import Linear.Epsilon (nearZero) +combineShellsToSolid :: Ptr TopoDS.Shape -> Acquire (Ptr TopoDS.Shape) +combineShellsToSolid s = do + explorer <- TopExp.Explorer.new s TopAbs.ShapeEnum.Shell + makeSolid <- MakeSolid.new + let go = do + isMore <- liftIO $ TopExp.Explorer.more explorer + when isMore $ do + shell <- liftIO $ unsafeDowncast =<< TopExp.Explorer.value explorer + liftIO $ MakeSolid.add makeSolid shell + liftIO $ TopExp.Explorer.next explorer + go + go + upcast <$> MakeSolid.solid makeSolid + -- | Expand or contract a `Solid` by a certain amount. -- -- This seems to be relatively fragile on Sweeps/Prisms @@ -29,7 +49,4 @@ --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) - shellBuilder <- MakeSolid.new - liftIO $ MakeSolid.add shellBuilder =<< unsafeDowncast shell - MakeShape.shape (upcast shellBuilder) - + combineShellsToSolid shell diff --git a/src/Waterfall/TwoD/Text.hs b/src/Waterfall/TwoD/Text.hs --- a/src/Waterfall/TwoD/Text.hs +++ b/src/Waterfall/TwoD/Text.hs @@ -8,6 +8,7 @@ import qualified Waterfall.TwoD.Internal.Shape as Shape import Waterfall.Internal.Finalizers (toAcquire, fromAcquire, unsafeFromAcquire) +import Waterfall.IO (WaterfallIOException (..), WaterfallIOExceptionCause (FileError)) import qualified OpenCascade.GP.Ax3 as GP.Ax3 import qualified OpenCascade.Font.BRepFont as BRepFont import qualified OpenCascade.Font.BRepTextBuilder as BRepTextBuilder @@ -16,6 +17,7 @@ import Foreign.Ptr import Control.Monad (unless) import OpenCascade.Font.FontAspect (FontAspect (..)) +import Control.Exception (throwIO) newtype Font = Font { rawFont :: Ptr BRepFont.BRepFont } @@ -24,7 +26,7 @@ fontFromPath fontpath size = do bRepFont <- fromAcquire $ BRepFont.new fontOk <- BRepFont.initFromPathAndSize bRepFont fontpath size - unless (fontOk) $ error ("Unable to initialize font from filepath: " <> fontpath) + unless (fontOk) $ throwIO (WaterfallIOException FileError fontpath) return $ Font bRepFont -- | Create a font from a system font name, aspect, and size @@ -32,7 +34,7 @@ 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) + unless (fontOk) $ throwIO $ WaterfallIOException FileError (name <> "::" <> show aspect) return $ Font bRepFont -- | Render text, using the font from the provided filepath, at a given size. diff --git a/waterfall-cad.cabal b/waterfall-cad.cabal --- a/waterfall-cad.cabal +++ b/waterfall-cad.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: waterfall-cad -version: 0.2.1.0 +version: 0.2.2.0 synopsis: Declarative CAD/Solid Modeling Library description: Please see the README on GitHub at category: Graphics @@ -38,6 +38,7 @@ Waterfall.Internal.Finalizers Waterfall.Internal.FromOpenCascade Waterfall.Internal.Path + Waterfall.Internal.Remesh Waterfall.Internal.Solid Waterfall.IO Waterfall.Offset @@ -60,10 +61,11 @@ 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 + , filepath >=1.4 && <1.6 , lattices >=2.0 && <3 , lens ==5.* , linear >=1.21 && <2 - , opencascade-hs >=0.2.1.0 && <0.3 + , opencascade-hs >=0.2.2.0 && <0.3 , primitive >=0.7 && <0.10 , resourcet >=1.2 && <1.4 default-language: Haskell2010