waterfall-cad 0.6.3.2 → 0.7.0.0

raw patch · 48 files changed

+2053/−492 lines, 48 filesdep +bifunctorsdep +containersdep +deepseqdep −primitivedep ~basedep ~opencascade-hsPVP ok

version bump matches the API change (PVP)

Dependencies added: bifunctors, containers, deepseq

Dependencies removed: primitive

Dependency ranges changed: base, opencascade-hs

API changes (from Hackage documentation)

Files

• CHANGELOG.md +63/−0
• doc-images/aqua.svg +5/−0
• doc-images/black.svg +4/−0
• doc-images/blue.svg +4/−0
• doc-images/fuchsia.svg +4/−0
• doc-images/green.svg +4/−0
• doc-images/grey.svg +4/−0
• doc-images/lime.svg +4/−0
• doc-images/maroon.svg +4/−0
• doc-images/navy.svg +4/−0
• doc-images/olive.svg +4/−0
• doc-images/purple.svg +4/−0
• doc-images/red.svg +4/−0
• doc-images/silver.svg +4/−0
• doc-images/teal.svg +4/−0
• doc-images/white.svg +4/−0
• doc-images/yellow.svg +4/−0
• src/Waterfall.hs +8/−0
• src/Waterfall/BoundingBox/Oriented.hs +16/−8
• src/Waterfall/Colour.hs +78/−0
• src/Waterfall/Diagram.hs +131/−31
• src/Waterfall/Error.hs +9/−1
• src/Waterfall/Fillet.hs +267/−84
• src/Waterfall/IO.hs +154/−39
• src/Waterfall/Internal/Diagram.hs +211/−11
• src/Waterfall/Internal/Edges.hs +35/−26
• src/Waterfall/Internal/Finalizers.hs +108/−54
• src/Waterfall/Internal/FromOpenCascade.hs +21/−0
• src/Waterfall/Internal/PaintHistory.hs +77/−0
• src/Waterfall/Internal/Path.hs +5/−3
• src/Waterfall/Internal/Path/Common.hs +24/−15
• src/Waterfall/Internal/ShapeMap.hs +51/−0
• src/Waterfall/Internal/Solid.hs +206/−28
• src/Waterfall/Loft.hs +3/−3
• src/Waterfall/Offset.hs +117/−46
• src/Waterfall/Paint.hs +208/−0
• src/Waterfall/Path/Common.hs +19/−14
• src/Waterfall/Revolution.hs +4/−4
• src/Waterfall/Solids.hs +32/−13
• src/Waterfall/Sweep.hs +7/−7
• src/Waterfall/Transforms.hs +22/−13
• src/Waterfall/TwoD/Internal/Path2D.hs +3/−1
• src/Waterfall/TwoD/Internal/Shape.hs +25/−17
• src/Waterfall/TwoD/Path2D.hs +5/−0
• src/Waterfall/TwoD/Shape.hs +6/−6
• src/Waterfall/TwoD/Text.hs +20/−15
• src/Waterfall/TwoD/Transforms.hs +25/−48
• waterfall-cad.cabal +28/−5

@@ -8,6 +8,69 @@  ## Unreleased +## 0.7.0.0++### Added++- Add support for OpenCASCADE-8.x.x+- Added `Waterfall.Colour`+- Added `Waterfall.Paint`+- Added `Waterfall.Solids.paintSolid` and `Waterfall.Solids.colourSolid`+- Added functions to `Waterfall.Fillet`+    - `roundFilletWithPaint`+    - `roundConditionalFilletWithPaint`+    - `roundIndexedConditionalFilletWithPaint`+    - `tryRoundFilletWithPaint`+    - `tryRoundConditionalFilletWithPaint`+    - `tryRoundIndexedConditionalFilletWithPaint`+    - `chamferWithPaint`+    - `conditionalChamferWithPaint`+    - `indexedConditionalChamferWithPaint`+    - `tryChamferWithPaint`+    - `tryConditionalChamferWithPaint`+    - `tryIndexedConditionalChamferWithPaint`+- Added functions to `Waterfall.Offset`+    - `offsetWithPaint`+    - `offsetWithToleranceWithPaint`+    - `tryOffsetWithPaint`+    - `tryOffsetWithToleranceWithPaint`+- Added `Waterfall.Diagram.getDiagramLines` and `Waterfall.Diagram.getDiagramFills`+- Added `Waterfall.Diagram.shapeDiagram`+- Added `Waterfall.Fillet.whenEndpointsNearlyEqual` (replacement for `whenNearlyEqual`)+- Added [`NFData`](https://hackage-content.haskell.org/package/deepseq/docs/Control-DeepSeq.html#t:NFData) instances for the following+  - `Waterfall.Solids.Solid`+  - `Waterfall.Path.Path`+  - `Waterfall.TwoD.Path2D.Path2D`+  - `Waterfall.TwoD.Path2D.Sense`+  - `Waterfall.TwoD.Shape.Shape`+  - `Waterfall.TwoD.Text.Font`+  - `Waterfall.BoundingBox.Oriented.OrientedBoundingBox`+  - `Waterfall.Diagram.Diagram`+  - `Waterfall.Diagram.LineType`+  - `Waterfall.Diagram.Visibility`+  - `Waterfall.Paint.Paint`+  - `Waterfall.Paint.DoubleSidedness`+  - `Waterfall.Colour.Colour`+  - `Waterfall.Error.WaterfallError`+- Added `Generic` instances for the following+  - `Waterfall.Diagram.Diagram`+  - `Waterfall.Colour.Colour`++### Changed++- `writeGLTF`/`writeGLB`/`writeOBJ` produce files with colours and material data+- `writeSTEP` produces files with colours+- Models may render differently based on this new colour and material data, even when they have not had a paint applied+- Functions in `Waterfall.Fillet` that used to take a predicate over endpoints (as a `(V3 Double, V3 Double) -> Maybe Double`) now take a `Path` (in the form `Path -> Maybe Double`)++### Removed+- `Waterfall.Fillet.whenNearlyEqual`++### Fixed +- Fixed a "use after free" bug, where OpenCascade objects could be destructed while still in use.+  - Specifically, the code that links OpenCascade destructors into the Haskell Garbage Collector no longer allows destructors to be associated to any object: they now must be associated to a `ForeignPtr`. This should eliminate a category of bugs.++ ## 0.6.3.2  - Fix an issue when the `offset` functions were applied to `Solid`s with multiple separate parts ("Compounds" in OpenCascade terms)

@@ -0,0 +1,5 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#00FFFF"/>+</svg>+<!-- touched -->

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#000000"/>+</svg>

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#0000FF"/>+</svg>

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#FF00FF"/>+</svg>

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#008000"/>+</svg>

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#808080"/>+</svg>

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#00FF00"/>+</svg>

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#800000"/>+</svg>

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#000080"/>+</svg>

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#808000"/>+</svg>

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#800080"/>+</svg>

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#FF0000"/>+</svg>

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#C0C0C0"/>+</svg>

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#008080"/>+</svg>

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#FFFFFF"/>+</svg>

@@ -0,0 +1,4 @@+<?xml version='1.0' ?>+<svg xmlns="http://www.w3.org/2000/svg" width="32" height="32">+  <rect width="32" height="32" fill="#FFFF00"/>+</svg>

@@ -23,6 +23,12 @@ --  -- The `Waterfall.IO` module also supports reading `Solid`s from a variety of file formats. , module Waterfall.IO+-- | Some basic colours, mostly used by `Waterfall.Paint`+, module Waterfall.Colour+-- | `Paint` can be applied to a `Solid` to affect how it appears +-- +-- (only supported by some file formats, see the documentation of `Waterfall.IO` for specifics)+, module Waterfall.Paint -- | Calculating Axis Aligned Bounding Boxes from a `Solid`. , module Waterfall.BoundingBox.AxisAligned -- | Calculating Oriented Bounding Boxes from a `Solid`.@@ -66,6 +72,8 @@ import Waterfall.Diagram import Waterfall.Fillet import Waterfall.IO+import Waterfall.Colour+import Waterfall.Paint import Waterfall.Offset import Waterfall.Path.Common import Waterfall.Path

@@ -9,8 +9,8 @@ ) where  import Linear (V3 (..), normalize, (^*))-import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire)-import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)+import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire, emptyPaintMap)+import Waterfall.Internal.Finalizers (acquireForeignPtr, unsafeFromAcquirePtr, unsafeFromAcquire) import Waterfall.Internal.FromOpenCascade (gpXYZToV3) import Foreign.Ptr (Ptr) import Waterfall.Solids (volume, box)@@ -23,27 +23,34 @@ import qualified OpenCascade.GP.Trsf as Trsf import qualified OpenCascade.BRepBndLib as BRepBndLib import qualified OpenCascade.BRepBuilderAPI.Transform  as BRepBuilderAPI.Transform+import qualified OpenCascade.BRepBuilderAPI.MakeShape as BRepBuilderAPI.MakeShape+import OpenCascade.Inheritance (upcast) import Data.Acquire (Acquire) import Control.Monad.IO.Class (liftIO) import Control.Monad ((<=<))+import Foreign.ForeignPtr (ForeignPtr)+import Control.DeepSeq (NFData (rnf), rwhnf)  -- | An OrientedBoundingBox may be a tighter fit for a Shape than an axis aligned bounding box would be -- -data OrientedBoundingBox = OrientedBoundingBox { rawOBB :: Ptr OBB }+newtype OrientedBoundingBox = OrientedBoundingBox { rawOBB :: ForeignPtr OBB } +instance NFData OrientedBoundingBox where +    rnf (OrientedBoundingBox obb) = rwhnf obb+ -- | Compute an OrientedBoundingBox for a solid orientedBoundingBox :: Solid -> Maybe OrientedBoundingBox orientedBoundingBox s =      if volume s == 0         then Nothing -        else Just . OrientedBoundingBox . unsafeFromAcquire $ do+        else Just . OrientedBoundingBox . unsafeFromAcquirePtr $ 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)+queryOBB f = unsafeFromAcquire . ( f <=< acquireForeignPtr . rawOBB)  -- | The center point of an `OrientedBoundingBox` obbCenter :: OrientedBoundingBox -> V3 Double@@ -78,8 +85,8 @@  -- | Reify an `OrientedBoundingBox` as a `Solid` obbToSolid :: OrientedBoundingBox -> Solid-obbToSolid obb = solidFromAcquire $ do-    obb' <- toAcquire . rawOBB $ obb+obbToSolid obb = solidFromAcquire emptyPaintMap $ do+    obb' <- acquireForeignPtr . rawOBB $ obb     x <- liftIO . OBB.xHSize $ obb'     y <- liftIO . OBB.yHSize $ obb'     z <- liftIO . OBB.zHSize $ obb'@@ -89,4 +96,5 @@     o <- Ax3.fromAx2 =<< GP.xoy     trsf <- Trsf.new     liftIO $ Trsf.setDisplacement trsf o position-    BRepBuilderAPI.Transform.transform unpositioned trsf True+    BRepBuilderAPI.MakeShape.shape +        =<< fmap upcast (BRepBuilderAPI.Transform.fromShapeTrsfAndCopy unpositioned trsf True)

@@ -0,0 +1,78 @@+{-#LANGUAGE DeriveGeneric #-}+module Waterfall.Colour+( Colour (..)+, rgb24+, black+, white+, silver+, grey+, maroon+, red+, purple+, fuchsia+, green+, lime+, olive+, yellow +, navy+, blue+, teal+, aqua+) where++import Data.Word (Word32)+import Data.Bits (shiftR, (.&.))+import GHC.Generics (Generic)+import Control.DeepSeq (NFData)++-- | Three sRGB values, in the range [0, 1]+data Colour = Colour Double Double Double+    deriving (Eq, Ord, Show, Generic)++instance NFData Colour++-- | Convert an integer into a Colour+--+-- This is useful because it lets you write hex codes, e.g.+-- +-- @+-- rgb24 0xFFFFFF == white+-- @+rgb24 :: Word32 -> Colour+rgb24 rgb =+    let channel shift = fromIntegral ((rgb `shiftR` shift) .&. 0xFF) / 255+    in Colour (channel 16) (channel 8) (channel 0)++black, white, silver, grey, maroon, red, purple, fuchsia, green, lime, olive, yellow, navy, blue, teal, aqua :: Colour+-- | <<doc-images/black.svg black>>+black = rgb24 0x000000+-- | <<doc-images/white.svg white>>+white = rgb24 0xFFFFFF+-- | <<doc-images/silver.svg silver>>+silver = rgb24 0xC0C0C0+-- | <<doc-images/grey.svg grey>>+grey = rgb24 0x808080+-- | <<doc-images/maroon.svg maroon>>+maroon = rgb24 0x800000+-- | <<doc-images/red.svg red>>+red = rgb24 0xFF0000+-- | <<doc-images/purple.svg purple>>+purple = rgb24 0x800080+-- | <<doc-images/fuchsia.svg fuchsia>>+fuchsia = rgb24 0xFF00FF+-- | <<doc-images/green.svg green>>+green = rgb24 0x008000+-- | <<doc-images/lime.svg lime>>+lime = rgb24 0x00FF00+-- | <<doc-images/olive.svg olive>>+olive = rgb24 0x808000+-- | <<doc-images/yellow.svg yellow>>+yellow = rgb24 0xFFFF00+-- | <<doc-images/navy.svg navy>>+navy = rgb24 0x000080+-- | <<doc-images/blue.svg blue>>+blue = rgb24 0x0000FF+-- | <<doc-images/teal.svg teal>>+teal = rgb24 0x008080+-- | <<doc-images/aqua.svg aqua>>+aqua = rgb24 0x00FFFF

@@ -1,10 +1,15 @@ {-# LANGUAGE DerivingVia #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveGeneric #-} module Waterfall.Diagram ( Diagram+, getDiagramFills+, getDiagramLines , LineType (..) , Visibility (..) , solidDiagram , pathDiagram+, shapeDiagram , diagramLines , diagramBoundingBox ) where@@ -13,7 +18,7 @@ import Linear.V2 (V2) import Linear (_xy) import Control.Lens ((^.))-import Waterfall.Internal.Solid (Solid (), acquireSolid)+import Waterfall.Internal.Solid (Solid (solidPaintMap), acquireSolid) import qualified OpenCascade.HLRBRep.TypeOfResultingEdge as HLRBRep import qualified OpenCascade.HLRBRep.Algo as HLRBRep.Algo import qualified OpenCascade.HLRAlgo.Projector as HLRAlgo.Projector@@ -22,25 +27,66 @@ 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.Internal.ToOpenCascade (v3ToDir, v3ToVertex) import Waterfall.TwoD.Internal.Path2D (Path2D (..)) import Control.Monad.IO.Class (liftIO)-import Waterfall.Internal.Finalizers (unsafeFromAcquire, unsafeFromAcquireT)+import Waterfall.Internal.Finalizers (unsafeFromAcquire, acquireForeignPtr, fromAcquirePtrT) 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.TwoD.Transforms (Transformable2D (..)) import Waterfall.Internal.FromOpenCascade (gpPntToV3) import OpenCascade.Inheritance (upcast)-import Control.Monad (forM_)+import Control.Monad (forM_, (<=<))+import Data.Map (Map)+import Waterfall.TwoD.Internal.Shape (Shape (..))+import Waterfall.Paint (Paint)+import qualified Data.Map as M+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Either (partitionEithers)+import Waterfall.Internal.Diagram (buildSolidDiagramFills)+import Waterfall.TwoD.Shape (shapePaths)+import GHC.Generics (Generic)+import Control.DeepSeq (NFData (rnf), rwhnf)  -- | `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+-- Contains:+--+-- * A collection of `Path2D` indexed by `LineType` and `Visibility`+-- * A collection of pairs of `Paint` and `Shape`, representing flat regions of colour+data Diagram = Diagram+     -- | The `Diagram`'s lines+     { getDiagramLines :: Map (LineType, Visibility) [Path2D]+     -- | Flat regions of colour+     , getDiagramFills :: [(Paint, Shape)]+     } deriving Generic +instance NFData Diagram++instance Semigroup Diagram where+    a <> b = Diagram +        { getDiagramLines = M.unionWith (<>) (getDiagramLines a) (getDiagramLines b)+        , getDiagramFills = getDiagramFills a <> getDiagramFills b+        }++instance Monoid Diagram where+    mempty = Diagram mempty mempty++mapDiagram :: (forall a. Transformable2D a => a -> a) -> Diagram -> Diagram+mapDiagram f (Diagram theLines theFills) =+    Diagram +        { getDiagramLines = fmap (fmap f) theLines+        , getDiagramFills = fmap (fmap f) theFills+        }++instance Transformable2D Diagram where+  matTransform2D m = mapDiagram (matTransform2D m)+  rotate2D theta = mapDiagram (rotate2D theta)+  scale2D s = mapDiagram (scale2D s)+  uScale2D s = mapDiagram (uScale2D s)+  translate2D v = mapDiagram (translate2D v)+  mirror2D v = mapDiagram (mirror2D v)+ -- | Categorize the lines in a diagram data LineType =      -- | Represents lines at the edge of objects, the "silhouette" @@ -52,6 +98,15 @@     | RawLine HLRBRep.TypeOfResultingEdge     deriving (Eq, Ord, Show) +instance NFData LineType where+    rnf (RawLine t) = rwhnf t+    rnf other = rwhnf other++normaliseLineType :: LineType -> LineType+normaliseLineType (RawLine HLRBRep.Sharp) = SharpLine+normaliseLineType (RawLine HLRBRep.OutLine) = OutLine+normaliseLineType other = other+ lineTypeToOpenCascade :: LineType -> HLRBRep.TypeOfResultingEdge lineTypeToOpenCascade OutLine = HLRBRep.OutLine lineTypeToOpenCascade SharpLine = HLRBRep.Sharp@@ -60,11 +115,13 @@ -- | Whether an edge is visible in a given projection, or not data Visibility = Visible | Hidden deriving (Eq, Ord, Show) +instance NFData Visibility where rnf = rwhnf+ -- | 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+solidDiagram projectionDirection solid =  unsafeFromAcquire $ do     s' <- acquireSolid solid     algo <- HLRBRep.Algo.new     liftIO $ HLRBRep.Algo.add algo s'@@ -78,43 +135,86 @@      extractor <- HLRBRep.HLRToShape.fromAlgo algo -    return $ \lt v is3D -> do-        compoundOfEdges <- HLRBRep.HLRToShape.compoundOfEdges extractor lt v is3D-        rawEdges <- allEdges compoundOfEdges-        traverse buildEdgeCurve3D rawEdges+    theLines <- fmap M.fromList . sequence $+        [ do+            compoundOfEdges <- HLRBRep.HLRToShape.compoundOfEdges +                extractor +                (lineTypeToOpenCascade lt) +                (visibility == Visible) +                False+            rawEdges <- allEdges compoundOfEdges+            wires <- liftIO . fromAcquirePtrT $ traverse ( edgeToWire <=< buildEdgeCurve3D) rawEdges+            return ((lt, visibility), Path2D . ComplexRawPath <$> wires) +        | lt <- +            [ OutLine+            , SharpLine+            , RawLine HLRBRep.IsoLine+            , RawLine HLRBRep.Rg1Line+            , RawLine HLRBRep.RgNLine+        ]+        , visibility <- [Visible, Hidden]+        ]++    theFills <-  buildSolidDiagramFills +        (solidPaintMap solid) +        s' +        projectionDirection +        projector+        extractor ++    return $ Diagram +        { getDiagramLines = theLines+        , getDiagramFills = theFills+        }+        + -- | 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 []+pathDiagram lt v path = Diagram+    { getDiagramLines = M.singleton (normaliseLineType lt, v) [path]+    , getDiagramFills = []+    } +-- | Produce a `Diagram` from a `Shape` and `Paint`+--+-- @ getDiagramFills . uncurry shapeDiagram = pure @+shapeDiagram :: Paint -> Shape -> Diagram+shapeDiagram paint shape = Diagram+    { getDiagramLines = mempty+    , getDiagramFills = [(paint, shape)]+    }+ -- | 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+diagramLines lt v = fromMaybe [] . M.lookup (normaliseLineType lt, v) . getDiagramLines  -- | 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+    let outline = diagramLines OutLine Visible d+    let sharpLine = diagramLines SharpLine Visible d+        fillLines = concatMap (shapePaths . snd) $ getDiagramFills d+    let allLines = outline <> sharpLine <> fillLines+    let partitionLine (Path2D (ComplexRawPath wire)) = Just (Left wire)+        partitionLine (Path2D (SinglePointRawPath point)) = Just (Right point)+        partitionLine _ = Nothing+        (allWires, allPoints) = partitionEithers . mapMaybe partitionLine $ allLines+    if null allWires && null allPoints         then pure Nothing         else do             theBox <- Bnd.Box.new-            forM_ allLines $ \s -> (liftIO $ BRepBndLib.addOptimal (upcast s) theBox True False)+            forM_ allWires $ \wire -> do+                w <- acquireForeignPtr wire+                liftIO $ BRepBndLib.addOptimal (upcast w) theBox True False+            forM_ allPoints $ \point -> do+                v <- v3ToVertex point+                liftIO $ BRepBndLib.addOptimal (upcast v) theBox True False+             p1 <- liftIO . gpPntToV3 =<< Bnd.Box.cornerMin theBox             p2 <- liftIO . gpPntToV3 =<< Bnd.Box.cornerMax theBox             return $ Just (p1 ^. _xy, p2 ^. _xy)

@@ -3,8 +3,16 @@ ) where  import Data.Data (Typeable)-import OpenCascade.Internal.Exception (OpenCascadeException)+import OpenCascade.Internal.Exception (OpenCascadeException (..))+import Control.DeepSeq(NFData (rnf)) +-- | Error type, wrapping an `OpenCascadeException` thrown from the kernel newtype WaterfallError = WaterfallError      { rawOpenCascadeError :: OpenCascadeException     } deriving (Eq, Ord, Typeable, Show)++instance NFData WaterfallError where +    rnf (WaterfallError e) = case e of+        OpenCascadeStandardFailure a b c -> rnf a `seq` rnf b `seq` rnf c+        OpenCascadeStdException s -> rnf s+        OpenCascadeOtherException -> ()

@@ -1,188 +1,371 @@ {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-} module Waterfall.Fillet (  -- * Rounds -- | Fillet that adds radiused faces that are tangent to the two faces either side of an edge.--- +-- -- Sometimes, it may not be possible to construct a fillet because there is not enough space next to one of the fillet edges, -- Or because the geometry is too complicated for the fillet algorithm.   roundFillet+, roundFilletWithPaint , roundConditionalFillet+, roundConditionalFilletWithPaint , roundIndexedConditionalFillet+, roundIndexedConditionalFilletWithPaint , tryRoundFillet+, tryRoundFilletWithPaint , tryRoundConditionalFillet+, tryRoundConditionalFilletWithPaint , tryRoundIndexedConditionalFillet+, tryRoundIndexedConditionalFilletWithPaint -- * Chamfers -- | Adds flat faces at a constant angle to the two faces either side of an edge. , chamfer+, chamferWithPaint , conditionalChamfer+, conditionalChamferWithPaint , indexedConditionalChamfer+, indexedConditionalChamferWithPaint , tryChamfer+, tryChamferWithPaint , tryConditionalChamfer+, tryConditionalChamferWithPaint , tryIndexedConditionalChamfer+, tryIndexedConditionalChamferWithPaint -- * Utility Methods-, whenNearlyEqual+, whenEndpointsNearlyEqual ) where -import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquireWithCatch)-import Waterfall.Internal.Edges (edgeEndpoints)+import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquireWithPaintMapWithCatch, makeShapeHistory)+import Waterfall.Internal.Edges (allEdges)+import Waterfall.Internal.Path (Path (..))+import Waterfall.Path (pathEndpoints)  import Waterfall.Error (WaterfallError) import qualified OpenCascade.BRepFilletAPI.MakeFillet as MakeFillet import qualified OpenCascade.BRepFilletAPI.MakeChamfer as MakeChamfer import qualified OpenCascade.BRepBuilderAPI.MakeShape as MakeShape-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.TopoDS.Types as TopoDS import Foreign.Ptr (Ptr)-import Control.Monad (when)+import Control.Monad (forM, forM_) import Control.Monad.IO.Class (liftIO)-import OpenCascade.Inheritance (upcast, unsafeDowncast)+import OpenCascade.Inheritance (upcast, SubTypeOf, unsafeDowncast) import Linear.V3 (V3 (..))-import Linear.Epsilon (Epsilon, nearZero)-import Control.Lens (Lens', (^.))+import Linear.Epsilon ( nearZero, Epsilon)+import Control.Lens ((^.), Getter) import Data.Either (fromRight)+import Waterfall.Paint (Paint)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE+import Data.Acquire (Acquire)+import Data.Maybe (catMaybes)+import Data.Foldable (find)+import qualified OpenCascade.BRepBuilderAPI as BRepBuilderAPI+import qualified OpenCascade.BRepBuilderAPI.MakeWire as MakeWire+import qualified OpenCascade.TopoDS.Shape as TopoDS.Shape+import Waterfall.Internal.PaintHistory (remapWithBlendFunction)+import Waterfall.Internal.Path.Common (RawPath(ComplexRawPath))+import Waterfall.Internal.Finalizers (fromAcquirePtr) -addEdges :: (Integer -> (V3 Double, V3 Double) -> Maybe Double) -> (Double -> Ptr TopoDS.Edge -> IO ()) -> Ptr Explorer.Explorer -> IO ()-addEdges radiusFn action explorer = go [] 0-    where go visited i = do-            isMore <- Explorer.more explorer-            when isMore $ do-                v <- unsafeDowncast =<< Explorer.value explorer-                hash <- TopTools.ShapeMapHasher.hash (upcast v)-                if hash `elem` visited-                    then do-                        Explorer.next explorer-                        go visited i-                    else do-                        endpoints <- edgeEndpoints v-                        case radiusFn i endpoints of -                            Just r | r > 0 -> action r v-                            _ -> pure ()-                        Explorer.next explorer-                        go (hash:visited) (i + 1) +edgeToPath :: Ptr TopoDS.Edge -> IO Path+edgeToPath edge = fmap (Path . ComplexRawPath) . fromAcquirePtr $ do+    builder <- MakeWire.new+    liftIO . MakeWire.addEdge builder +        =<<  liftIO . unsafeDowncast +        =<< TopoDS.Shape.copy (upcast edge)+    MakeWire.wire builder +getEdgesWithRadius :: (Integer -> Path -> Maybe Double) -> Ptr TopoDS.Shape -> Acquire [(Double, Ptr TopoDS.Edge)]+getEdgesWithRadius f s = do+    edges <- allEdges s+    fmap catMaybes . forM (zip [0..] edges) $ \(i, e) -> do+        path <- liftIO . edgeToPath $ e+        return $ (, e) <$> find (> 0) (f i path) --- | Version of `roundIndexedConditionalFillet` that returns an `Either` on failure-tryRoundIndexedConditionalFillet-    :: (Integer -> (V3 Double, V3 Double) -> Maybe Double)+trySomeIndexedConditionalFilletWithPaint+    :: (SubTypeOf BRepBuilderAPI.MakeShape a)+    => (Ptr TopoDS.Shape -> Acquire (Ptr a))+    -> (Ptr a -> Double -> Ptr TopoDS.Edge -> IO ())+    -> (NonEmpty Paint -> Paint)+    -> (Integer -> Path -> Maybe Double)     -> Solid     -> Either WaterfallError Solid-tryRoundIndexedConditionalFillet radiusFunction solid = solidFromAcquireWithCatch $ do-    s <- acquireSolid solid-    builder <- MakeFillet.fromShape s+trySomeIndexedConditionalFilletWithPaint makeBuilder addEdge paintFunction radiusFunction solid =+    solidFromAcquireWithPaintMapWithCatch $ do+        s <- acquireSolid solid+        builder <- makeBuilder s -    explorer <- Explorer.new s ShapeEnum.Edge-    liftIO $ addEdges radiusFunction (MakeFillet.addEdgeWithRadius builder) explorer+        edgesWithRadius <- getEdgesWithRadius radiusFunction s -    MakeShape.shape (upcast builder)+        liftIO $ forM_ edgesWithRadius (uncurry (addEdge builder)) --- | Add rounds with the given radius to each edge of a solid, conditional on the endpoints of the edge, and the index of the edge.--- +        resultShape <- MakeShape.shape (upcast builder)++        newPaintMap <-+            remapWithBlendFunction+                paintFunction+                s+                (snd <$> edgesWithRadius)+                (makeShapeHistory . upcast $ builder)+                (solidPaintMap solid)++        pure (newPaintMap, resultShape)++-- | Version of `tryRoundIndexedConditionalFillet`+--+-- Exposes how to assign `Paint` to the fillet surface+tryRoundIndexedConditionalFilletWithPaint+    :: (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a fillet surface to the `Paint` used for the surface+    -> (Integer -> Path -> Maybe Double) -- ^ Maps the edge index and the edge path to the fillet radius+    -> Solid+    -> Either WaterfallError Solid+tryRoundIndexedConditionalFilletWithPaint =+    trySomeIndexedConditionalFilletWithPaint MakeFillet.fromShape MakeFillet.addEdgeWithRadius++-- | Version of `roundIndexedConditionalFillet` that returns an `Either` on failure+tryRoundIndexedConditionalFillet+    :: (Integer -> Path -> Maybe Double) -- ^ Maps the edge index and the edge path to the fillet radius+    -> Solid+    -> Either WaterfallError Solid+tryRoundIndexedConditionalFillet =+    tryRoundIndexedConditionalFilletWithPaint NE.head++-- | Add rounds with the given radius to each edge of a solid, conditional on the path of the edge, and the index of the edge.+-- -- This can be used to selectively round\/fillet a `Solid`. -- -- In general, relying on the edge index is inelegant,--- however, if you consider a Solid with a semicircular face, --- there's no way to select either the curved or the flat edge of the semicircle based on just the endpoints. ----- Being able to selectively round\/fillet based on edge index is an \"easy\" way to round\/fillet these shapes. +-- In an earlier version of Waterfall-CAD, fillets were controlled by the edge *endpoints*, rather than the edge path+--  +-- If you consider a Solid with a semicircular face,+-- there's no way to select either the curved or the flat edge of the semicircle based on just the endpoints+--+-- Now that fillets can be constructed based on the whole `Path` of the edge, this argument holds less water.+--+-- But being able to selectively round\/fillet based on edge index is still an \"easy\" way to round\/fillet these shapes. roundIndexedConditionalFillet-    :: (Integer -> (V3 Double, V3 Double) -> Maybe Double)+    :: (Integer -> Path -> Maybe Double) -- ^ Maps the edge index and the edge `Path` to the fillet radius     -> Solid     -> Solid roundIndexedConditionalFillet radiusFunction solid = fromRight mempty $ tryRoundIndexedConditionalFillet radiusFunction solid  +-- | Version of `roundIndexedConditionalFillet`+--+-- Exposes how to assign `Paint` to the fillet surface+roundIndexedConditionalFilletWithPaint+    :: (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a fillet surface to the `Paint` used for the surface+    -> (Integer -> Path -> Maybe Double) -- ^ Maps the edge index and the edge `Path` to the fillet radius+    -> Solid+    -> Solid+roundIndexedConditionalFilletWithPaint paintFn radiusFunction solid =+    fromRight mempty $ tryRoundIndexedConditionalFilletWithPaint paintFn radiusFunction solid+ -- | Version of `roundConditionalFillet` that returns an `Either` on failure-tryRoundConditionalFillet -    :: ((V3 Double, V3 Double) -> Maybe Double)-    -> Solid +tryRoundConditionalFillet+    :: (Path -> Maybe Double) -- ^ Maps the edge `Path` to the fillet radius+    -> Solid     -> Either WaterfallError Solid tryRoundConditionalFillet f = tryRoundIndexedConditionalFillet (const f) --- | Add rounds with the given radius to each edge of a solid, conditional on the endpoints of the edge.--- +-- | Version of `tryRoundConditionalFillet`+--+-- Exposes how to assign `Paint` to the fillet surface+tryRoundConditionalFilletWithPaint+    :: (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a fillet surface to the `Paint` used for the surface+    -> (Path -> Maybe Double) -- ^ Maps the edge `Path` to the fillet radius+    -> Solid+    -> Either WaterfallError Solid+tryRoundConditionalFilletWithPaint paintFn f = tryRoundIndexedConditionalFilletWithPaint paintFn (const f)++-- | Add rounds with the given radius to each edge of a solid, conditional on the `Path` of the edge.+-- -- This can be used to selectively round\/fillet a `Solid`.-roundConditionalFillet :: ((V3 Double, V3 Double) -> Maybe Double) -> Solid -> Solid+roundConditionalFillet+    :: (Path -> Maybe Double) -- ^ Maps the edge `Path` to the fillet radius+    -> Solid -> Solid roundConditionalFillet f = roundIndexedConditionalFillet (const f) +-- | Version of `roundConditionalFillet`+--+-- Exposes how to assign `Paint` to the fillet surface+roundConditionalFilletWithPaint+    :: (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a fillet surface to the `Paint` used for the surface+    -> (Path -> Maybe Double) -- ^ Maps the edge `Path` to the fillet radius+    -> Solid -> Solid+roundConditionalFilletWithPaint paintFn f =+    roundIndexedConditionalFilletWithPaint paintFn (const f)+ -- | Add a round with a given radius to every edge of a solid -- -- Because this is applied to both internal (concave) and external (convex) edges, it may technically produce both Rounds and Fillets-roundFillet :: Double -> Solid -> Solid+roundFillet+    :: Double -- ^ The fillet radius+    -> Solid -> Solid roundFillet r = roundConditionalFillet (const . pure $ r)  +-- | Version of `roundFillet`+--+-- Exposes how to assign `Paint` to the fillet surface+roundFilletWithPaint+    :: (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a fillet surface to the `Paint` used for the surface+    -> Double -- ^ The fillet radius+    -> Solid -> Solid+roundFilletWithPaint paintFn r+    = roundConditionalFilletWithPaint paintFn (const . pure $ r)+ -- | Version of `roundFillet` that returns an `Either` on failure-tryRoundFillet :: Double -> Solid -> Either WaterfallError Solid+tryRoundFillet+    :: Double -- ^ The fillet radius+    -> Solid -> Either WaterfallError Solid tryRoundFillet r = tryRoundConditionalFillet (const . pure $ r) ---- | Version of `indexedConditionalChamfer` that returns an `Either` on failure-tryIndexedConditionalChamfer -    :: (Integer -> (V3 Double, V3 Double) -> Maybe Double)-    -> Solid +-- | Version of `tryRoundFillet`+--+-- Exposes how to assign `Paint` to the fillet surface+tryRoundFilletWithPaint+    :: (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a fillet surface to the `Paint` used for the surface+    -> Double -- ^ The fillet radius+    -> Solid     -> Either WaterfallError Solid-tryIndexedConditionalChamfer radiusFunction solid = solidFromAcquireWithCatch $ do-    s <- acquireSolid solid-    builder <- MakeChamfer.fromShape s+tryRoundFilletWithPaint paintFn r =+    tryRoundConditionalFilletWithPaint paintFn (const . pure $ r) -    explorer <- Explorer.new s ShapeEnum.Edge-    liftIO $ addEdges radiusFunction (MakeChamfer.addEdgeWithDistance builder) explorer+-- | Version of `tryIndexedConditionalChamfer`+--+-- Exposes how to assign `Paint` to the chamfer surface+tryIndexedConditionalChamferWithPaint+    :: (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a chamfer surface to the `Paint` used for the surface+    -> (Integer -> Path -> Maybe Double) -- ^ Maps the edge index and the edge `Path` to the chamfer size+    -> Solid+    -> Either WaterfallError Solid+tryIndexedConditionalChamferWithPaint =+    trySomeIndexedConditionalFilletWithPaint MakeChamfer.fromShape MakeChamfer.addEdgeWithDistance -    MakeShape.shape (upcast builder)+-- | Version of `indexedConditionalChamfer` that returns an `Either` on failure+tryIndexedConditionalChamfer+    :: (Integer -> Path -> Maybe Double) -- ^ Maps the edge index and the edge `Path` to the chamfer size+    -> Solid+    -> Either WaterfallError Solid+tryIndexedConditionalChamfer =+    tryIndexedConditionalChamferWithPaint NE.head --- | Add chamfers of the given size to each edge of a solid, conditional on the endpoints of the edge, and the index of the edge.--- +-- | Add chamfers of the given size to each edge of a solid, conditional on the `Path` of the edge, and the index of the edge.+-- -- This can be used to selectively chamfer a `Solid`. -- -- In general, relying on the edge index is inelegant,--- however, if you consider a Solid with a semicircular face, --- there's no way to select either the curved or the flat edge of the semicircle based on just the endpoints.+-- however, if you consider a Solid with a semicircular face,+-- there's no way to select either the curved or the flat edge of the semicircle based on just the `Path`. ----- Being able to selectively chamfer based on edge index is an \"easy\" way to chamfer these shapes. +-- Being able to selectively chamfer based on edge index is an \"easy\" way to chamfer these shapes. indexedConditionalChamfer-    :: (Integer -> (V3 Double, V3 Double) -> Maybe Double)-    -> Solid +    :: (Integer -> Path -> Maybe Double) -- ^ Maps the edge index and the edge `Path` to the chamfer size     -> Solid+    -> Solid indexedConditionalChamfer radiusFunction solid =     fromRight mempty $ tryIndexedConditionalChamfer radiusFunction solid +-- | Version of `indexedConditionalChamfer`+--+-- Exposes how to assign `Paint` to the chamfer surface+indexedConditionalChamferWithPaint+    :: (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a chamfer surface to the `Paint` used for the surface+    -> (Integer -> Path -> Maybe Double) -- ^ Maps the edge index and the edge `Path` to the chamfer size+    -> Solid+    -> Solid+indexedConditionalChamferWithPaint paintFn radiusFunction solid =+    fromRight mempty $ tryIndexedConditionalChamferWithPaint paintFn radiusFunction solid+ -- | Version of `conditionalChamfer` that returns an `Either` on failure-tryConditionalChamfer -    :: ((V3 Double, V3 Double) -> Maybe Double) +tryConditionalChamfer+    :: (Path -> Maybe Double) -- ^ Maps the edge `Path` to the chamfer size     -> Solid     -> Either WaterfallError Solid tryConditionalChamfer f = tryIndexedConditionalChamfer (const f) --- | Add chamfers with the given size to each edge of a solid, conditional on the endpoints of the edge.--- ++-- | Version of `tryConditionalChamfer`+--+-- Exposes how to assign `Paint` to the chamfer surface+tryConditionalChamferWithPaint+    :: (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a chamfer surface to the `Paint` used for the surface+    -> (Path -> Maybe Double)  -- ^ Maps the edge `Path` to the chamfer size+    -> Solid+    -> Either WaterfallError Solid+tryConditionalChamferWithPaint paintFn f = tryIndexedConditionalChamferWithPaint paintFn (const f)++-- | Add chamfers with the given size to each edge of a solid, conditional on the `Path` of the edge.+-- -- This can be used to selectively chamfer a `Solid`.-conditionalChamfer :: ((V3 Double, V3 Double) -> Maybe Double) -> Solid -> Solid+conditionalChamfer+    :: (Path -> Maybe Double)  -- ^ Maps the edge `Path` to the chamfer size+    -> Solid+    -> Solid conditionalChamfer f = indexedConditionalChamfer (const f) ++-- | Version of `conditionalChamfer`+--+-- Exposes how to assign `Paint` to the chamfer surface+conditionalChamferWithPaint+    :: (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a chamfer surface to the `Paint` used for the surface+    -> (Path -> Maybe Double) -- ^ Maps the edge `Path` to the chamfer size+    -> Solid -> Solid+conditionalChamferWithPaint paintFn f = indexedConditionalChamferWithPaint paintFn (const f)+ -- | Version of `chamfer` that returns an `Either` on failure tryChamfer :: Double -> Solid -> Either WaterfallError Solid tryChamfer d = tryConditionalChamfer (const . pure $ d) ++-- | Version of `tryChamfer`+--+-- Exposes how to assign `Paint` to the chamfer surface+tryChamferWithPaint+    :: (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a chamfer surface to the `Paint` used for the surface+    -> Double -- ^ The chamfer size+    -> Solid+    -> Either WaterfallError Solid+tryChamferWithPaint paintFn d = tryConditionalChamferWithPaint paintFn (const . pure $ d)+ -- | Add a chamfer with a given size to every edge of a solid -- -- This is applied to both internal (concave) and external (convex) edges-chamfer :: Double -> Solid -> Solid+chamfer+    :: Double -- ^ The chamfer size+    -> Solid -> Solid chamfer d = conditionalChamfer (const . pure $ d) --- | Returns a value when the target of a lens on two points are close to one another.--- +-- | Version of `chamfer`+--+-- Exposes how to assign `Paint` to the chamfer surface+chamferWithPaint+    :: (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a chamfer surface to the `Paint` used for the surface+    -> Double  -- ^ The chamfer size+    -> Solid -> Solid+chamferWithPaint paintFunction d =+    conditionalChamferWithPaint paintFunction (const . pure $ d )++-- | Returns a value when the target of a lens, when applied to the edge's `Path`'s endpoints are close to one another.+-- -- This can be used in combination with `roundConditionalFillet`/`conditionalChamfer`. -- -- Selecting only horizontal edges: ----- > roundConditionalFillet (whenNearlyEqual _z 2)+-- > roundConditionalFillet (whenEndpointsNearlyEqual _z 2) -- -- Selecting only vertical edges: ----- > roundConditionalFillet (whenNearlyEqual _xy 2)-whenNearlyEqual :: Epsilon a => Lens' point a -> r -> (point, point) -> Maybe r-whenNearlyEqual l res (s, e)-    | nearZero ((s ^. l) - (e ^. l))  = Just res-    | otherwise = Nothing                         +-- > roundConditionalFillet (whenEndpointsNearlyEqual _xy 2)+whenEndpointsNearlyEqual :: (Epsilon v) => Getter (V3 Double) v -> r -> Path -> Maybe r+whenEndpointsNearlyEqual l res path = +    case pathEndpoints path of +        Nothing -> Nothing+        Just (s, e) | nearZero ((s ^. l) - (e ^. l)) -> Just res+                    | otherwise -> Nothing++

@@ -24,43 +24,64 @@ , readOBJ ) where  -import Waterfall.Internal.Solid (Solid(..))+import Waterfall.Internal.Solid (Solid(..), PaintMap(..), emptyPaintMap, acquireSolid, paintMapIsEmpty) 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.NCollection.IndexedDataMap as NCollection.IndexedDataMap+import qualified OpenCascade.NCollection.Types as NCollection 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.XCAFDoc.ColorType as XCAFDoc.ColorType import qualified OpenCascade.TopoDS.Types as TopoDS import qualified OpenCascade.TopoDS.Shape as TopoDS.Shape import OpenCascade.Handle (Handle) import OpenCascade.Inheritance (upcast)+import qualified OpenCascade.Quantity as Quantity+import qualified OpenCascade.Quantity.Color as Quantity.Color+import qualified OpenCascade.Quantity.ColorRGBA as Quantity.ColorRGBA+import qualified OpenCascade.Quantity.TypeOfColor as Quantity.TypeOfColor import Control.Monad.IO.Class (liftIO)-import Control.Monad (unless, when)-import Waterfall.Internal.Finalizers (toAcquire, fromAcquire)+import Control.Monad (unless, when, forM, forM_, (<=<))+import Waterfall.Internal.Finalizers (acquireForeignPtr, fromAcquirePtr) import Data.Acquire ( Acquire, withAcquire ) import Foreign.Ptr (Ptr) import Data.Char (toLower) import System.FilePath (takeExtension) import Control.Exception (Exception, throwIO)+import OpenCascade.TDF.Label (Label)+import Waterfall.Paint (Colour(..), paintColour, defaultPaint, Paint, DoubleSidedness(..), paintName, paintOpacity, paintEmissiveColour, paintMetallic, paintDoubleSidedness, paintRoughness)+import qualified OpenCascade.XCAFDoc.ColorTool as XCafDoc.ColourTool+import Control.Lens ((^.), Getting)+import System.IO (hPutStrLn, stderr)+import qualified OpenCascade.STEPCAFControl.Writer as StepCAFControl.Writer+import qualified OpenCascade.XCAFDoc.Types as XCafDoc+import qualified OpenCascade.XCAFDoc.VisMaterial as XCafDoc.VisMaterial+import qualified OpenCascade.XCAFDoc.VisMaterialPBR as XCafDoc.VisMaterialPBR+import qualified OpenCascade.NCollection.Vec3 as NCollection.Vec3+import Data.Maybe (fromMaybe)+import qualified OpenCascade.XCAFDoc.VisMaterialTool as XCafDoc.VisMaterialTool+import Control.Applicative ((<|>), Alternative)+import qualified OpenCascade.Graphic3D.AlphaMode as AlphaMode+import qualified OpenCascade.Graphic3D.TypeOfBackfacingModel as TypeOfBackfacingModel +import Data.Map (Map)+import qualified Data.Map as M+ -- | The type of exceptions thrown by IO actions defined in `Waterfall.IO` data WaterfallIOException =      WaterfallIOException @@ -112,10 +133,9 @@         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+writeSTLAsciiOrBinary asciiMode linDeflection filepath (Solid ptr _paintMap) = (`withAcquire` pure) $ do+    s <- acquireForeignPtr ptr+    mesh linDeflection s     writer <- StlWriter.new     liftIO $ do             StlWriter.setAsciiMode writer asciiMode@@ -147,33 +167,125 @@ -- -- STEP files can be imported by [FreeCAD](https://www.freecad.org/) writeSTEP :: FilePath -> Solid -> IO ()-writeSTEP filepath (Solid ptr) = (`withAcquire` pure) $ do-    s <- toAcquire ptr-    writer <- StepWriter.new-    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+writeSTEP filepath (Solid ptr paintMap) = (`withAcquire` pure) $ do+    s <- acquireForeignPtr ptr+    writer <- StepCAFControl.Writer.new+    doc <- cafDocument s paintMap+    liftIO $ StepCAFControl.Writer.setColorMode writer (not . paintMapIsEmpty $ paintMap)+    resTransfer <- liftIO $ StepCAFControl.Writer.transfer writer doc StepModelType.Asls+    unless resTransfer (liftIO . throwIO $ WaterfallIOException BadGeometryError filepath)+    resWrite <- liftIO $ StepCAFControl.Writer.write writer filepath     unless (resWrite == IFSelect.ReturnStatus.Done) (liftIO . throwIO $ WaterfallIOException FileError filepath) -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+colourToOCColor :: Colour -> Acquire (Ptr Quantity.Color)+colourToOCColor (Colour r g b) =+    Quantity.Color.new r g b Quantity.TypeOfColor.SRGB+    +colourToOCVec3 :: Colour -> Acquire (Ptr (NCollection.Vec3 Float))+colourToOCVec3 (Colour r g b) =+    NCollection.Vec3.newVec3Float (realToFrac r) (realToFrac g) (realToFrac b)++paintLookup :: Alternative f => Paint -> Getting (f a) Paint (f a) -> f a+paintLookup paint lens = paint ^. lens <|> defaultPaint ^. lens++paintToMaterial :: Ptr (Handle XCafDoc.VisMaterialTool) -> Paint ->  Acquire (Ptr Label)+paintToMaterial tool paint = do+    pbrMaterial <- XCafDoc.VisMaterialPBR.new+    material <- XCafDoc.VisMaterial.new++    let opacity = fromMaybe 1.0 (paintLookup paint paintOpacity)++    forM_ (paintLookup paint paintColour) +        (liftIO . XCafDoc.VisMaterialPBR.setBaseColor pbrMaterial +            <=< flip Quantity.ColorRGBA.new opacity+            <=< colourToOCColor+        )+    forM_ (paintLookup paint paintEmissiveColour) +        (liftIO . XCafDoc.VisMaterialPBR.setEmissiveFactor pbrMaterial +            <=< colourToOCVec3+        )+    forM_ (paintLookup paint paintMetallic)+        (liftIO . XCafDoc.VisMaterialPBR.setMetallic pbrMaterial) ++    forM_ (paintLookup paint paintRoughness)+        (liftIO . XCafDoc.VisMaterialPBR.setRoughness pbrMaterial) +        +    forM_ (paintLookup paint paintName)+        (liftIO . XCafDoc.VisMaterial.setRawName material)++    let backfacing DoubleSided = TypeOfBackfacingModel.DoubleSided+        backfacing SingleSided = TypeOfBackfacingModel.BackCulled++    forM_ (paintLookup paint paintDoubleSidedness)+        (liftIO . XCafDoc.VisMaterial.setFaceCulling material . backfacing)+    +    liftIO $ XCafDoc.VisMaterial.setPbrMaterial material pbrMaterial+    let name = fromMaybe "" (paint ^. paintName)++    let alphaMode = if opacity < 1.0 then AlphaMode.BlendAuto else AlphaMode.Opaque+    liftIO $ XCafDoc.VisMaterial.setAlphaMode material alphaMode 0.5++    XCafDoc.VisMaterialTool.addMaterial tool material name++buildMaterialMap :: Ptr (Handle XCafDoc.VisMaterialTool) -> [Paint] ->  Acquire (Map Paint (Ptr Label))+buildMaterialMap tool paints = +    let dup a = (a, a)+    in forM (M.fromList (dup <$> paints)) (paintToMaterial tool)++addColourToCafWriter :: Ptr TopoDS.Shape -> Ptr Label -> PaintMap -> Acquire ()+addColourToCafWriter s shapeLabel paintMap = do+    colourTool <- XCafDoc.DocumentTool.colorTool shapeLabel+    materialTool <- XCafDoc.DocumentTool.visMaterialTool shapeLabel+    case paintMap of+        UniformPaint paint -> do+            forM_ (paint ^. paintColour) $ \color -> do+                ocColour <- colourToOCColor color+                colourWasSet <- liftIO $ XCafDoc.ColourTool.setShapeColor colourTool s ocColour XCAFDoc.ColorType.ColorSurf+                liftIO . unless colourWasSet $ hPutStrLn stderr "Inconsistency: Base Shape not found in CAF document"++            material <- paintToMaterial materialTool paint+            liftIO $ XCafDoc.VisMaterialTool.setShapeMaterial materialTool shapeLabel material+        FacePaints facePaints -> do+            forM_ (defaultPaint ^. paintColour) $ \color -> do+                ocColour <- colourToOCColor color+                colourWasSet <- liftIO $ XCafDoc.ColourTool.setShapeColor colourTool s ocColour XCAFDoc.ColorType.ColorSurf+                liftIO . unless colourWasSet $ hPutStrLn stderr "Inconsistency: Base Shape not found in CAF document"+            materialMap <- buildMaterialMap materialTool (snd <$> facePaints)+            forM_ facePaints $ \(face, paint) -> do+                face' <- acquireForeignPtr face+                forM_ (paint ^. paintColour) $ \colour -> do+                        ocColour <- colourToOCColor colour+                        colourWasSet <- liftIO $ XCafDoc.ColourTool.setShapeColor colourTool (upcast face') ocColour XCAFDoc.ColorType.ColorSurf+                        liftIO . unless colourWasSet $ hPutStrLn stderr "Inconsistency: Face not found in CAF document"+                forM_ (M.lookup paint materialMap) +                    (liftIO . XCafDoc.VisMaterialTool.setShapeMaterialFromShape materialTool (upcast face'))++mesh :: Double -> Ptr TopoDS.Shape -> Acquire ()+mesh linDeflection s = do+    mesher <- BRepMesh.IncrementalMesh.fromShapeAndLinDeflection s linDeflection+    liftIO $ BRepMesh.IncrementalMesh.perform mesher++cafDocument+    :: Ptr TopoDS.Shape +    -> PaintMap +    -> Acquire (Ptr (Handle TDocStd.Document))+cafDocument s paintMap = do     doc <- TDocStd.Document.fromStorageFormat ""     mainLabel <- TDocStd.Document.main doc     shapeTool <- XCafDoc.DocumentTool.shapeTool mainLabel-    _ <- XCafDoc.ShapeTool.addShape shapeTool s True True-    meta <- TColStd.IndexedDataMapOfStringString.new-    progress <- Message.ProgressRange.new-    write filepath doc meta progress+    shapeLabel <- XCafDoc.ShapeTool.addShape shapeTool s True False+    addColourToCafWriter s shapeLabel paintMap+    return doc  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+writeGLTFOrGLB binary linDeflection filepath solid = (`withAcquire` pure) $  do+    writer <- RWGltf.CafWriter.new filepath binary+    meta <- NCollection.IndexedDataMap.newAsciiStringMap+    progress <- Message.ProgressRange.new+    s <- acquireSolid solid+    mesh linDeflection s+    doc <- cafDocument s (solidPaintMap solid)+    liftIO $ RWGltf.CafWriter.perform writer doc meta progress  -- | Write a `Solid` to a glTF file at a given path --@@ -210,11 +322,14 @@ -- -- 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+writeOBJ linDeflection filepath solid = (`withAcquire` pure) $ do+    writer <- RWObj.CafWriter.new filepath+    meta <- NCollection.IndexedDataMap.newAsciiStringMap+    progress <- Message.ProgressRange.new+    s <- acquireSolid solid+    mesh linDeflection s+    doc <- cafDocument s (solidPaintMap solid)+    liftIO $ RWObj.CafWriter.perform writer doc meta progress  -- | Read a `Solid` from a file at a given path -- @@ -235,7 +350,7 @@  -- | Read a `Solid` from an STL file at a given path readSTL :: FilePath -> IO Solid-readSTL filepath = fmap Solid . fromAcquire $ do+readSTL filepath = fmap (`Solid` emptyPaintMap) . fromAcquirePtr $ do     shape <- TopoDS.Shape.new     reader <- StlReader.new     res <- liftIO $ StlReader.read reader shape filepath@@ -244,7 +359,7 @@  -- | Read a `Solid` from a STEP file at a given path readSTEP :: FilePath -> IO Solid-readSTEP filepath = fmap Solid . fromAcquire $ do+readSTEP filepath = fmap (`Solid` emptyPaintMap) . fromAcquirePtr $ do     reader <- STEPReader.new     status <- liftIO $ XSControl.Reader.readFile (upcast reader) filepath     _ <- liftIO $ XSControl.Reader.transferRoots (upcast reader)@@ -255,7 +370,7 @@     return shape  cafReader :: Acquire (Ptr RWMesh.CafReader) -> FilePath -> IO Solid-cafReader mkReader filepath = fmap Solid . fromAcquire $ do+cafReader mkReader filepath = fmap (`Solid` emptyPaintMap) . fromAcquirePtr $ do     reader <- mkReader     doc <- TDocStd.Document.fromStorageFormat ""     progress <- Message.ProgressRange.new

@@ -1,17 +1,217 @@-{-# OPTIONS_HADDOCK not-home #-}-module Waterfall.Internal.Diagram -( RawDiagram (..)+{-# LANGUAGE TupleSections #-}+module Waterfall.Internal.Diagram+( buildSolidDiagramFills ) where--import qualified OpenCascade.TopoDS as TopoDS+import Waterfall.Internal.Solid (PaintMap(..), materialiseFacePaints, paintMapIsEmpty)+import Waterfall.Paint (Paint)+import Waterfall.TwoD.Internal.Shape (Shape (..)) import Data.Acquire (Acquire)-import Foreign.Ptr (Ptr)+import Foreign (Ptr)+import qualified OpenCascade.HLRBRep.Types as HLRBRep import qualified OpenCascade.HLRBRep.TypeOfResultingEdge as HLRBRep+import qualified OpenCascade.TopoDS as TopoDS+import Waterfall.Internal.Edges (allEdges, buildEdgeCurve3D, allSubShapesWithCopy)+import Data.Traversable (forM)+import qualified OpenCascade.HLRBRep.HLRToShape as HLRBRep.HLRToShape+import qualified OpenCascade.Bnd.Box as Bnd.Box+import Data.Foldable (forM_)+import Control.Monad.IO.Class (liftIO)+import qualified OpenCascade.BRepBndLib as BRepBndLib+import qualified OpenCascade.BOPAlgo.Builder as BOPAlgo.Builder+import qualified OpenCascade.TopAbs.ShapeEnum as ShapeEnum+import qualified OpenCascade.TopoDS.Builder as TopoDS.Builder+import qualified OpenCascade.TopoDS.Compound as TopoDS.Compound+import OpenCascade.Inheritance (upcast, unsafeDowncast)+import Waterfall.Internal.FromOpenCascade (gpPntToV3)+import Control.Lens ((^.), (&), (.~), (<&>))+import Linear (_x, _y, _z, V3, norm)+import qualified Data.IntMap as IntMap+import Data.Maybe (fromMaybe, catMaybes)+import qualified Waterfall.Internal.ShapeMap as ShapeMap+import qualified OpenCascade.BOPAlgo.Tools as BOPAlgo.Tools+import qualified OpenCascade.HLRAlgo as HLRAlgo+import qualified OpenCascade.HLRAlgo.Projector as Projector+import qualified OpenCascade.IntCurvesFace.ShapeIntersector as ShapeIntersector+import Control.Arrow (first)+import qualified OpenCascade.BRepMesh.IncrementalMesh as IncrementalMesh+import qualified OpenCascade.TopLoc.Location as TopLoc.Location+import qualified OpenCascade.BRep.Tool as BRep.Tool+import qualified OpenCascade.BRepGProp as BRepGProp+import qualified OpenCascade.GProp.GProps as GProps+import qualified OpenCascade.Poly.Triangulation as Poly.Triangulation+import qualified OpenCascade.Poly.Triangle as Poly.Triangle+import Control.Monad ((<=<), filterM)+import Waterfall.Internal.ToOpenCascade (v3ToPnt, v3ToDir)+import qualified OpenCascade.GP.Pnt as GP.Pnt+import qualified OpenCascade.GP.Lin as GP.Lin+import Waterfall.Internal.Finalizers (fromAcquirePtr, fromAcquirePtrT)+import qualified OpenCascade.TopoDS.Shape as TopoDS.Shape+import qualified Data.Map as M+import qualified OpenCascade.ShapeUpgrade.UnifySameDomain as UnifySameDomain -newtype RawDiagram = RawDiagram { runDiagram :: HLRBRep.TypeOfResultingEdge -> Bool -> Bool -> Acquire [Ptr TopoDS.Edge] }+boundaryEdges :: Ptr HLRBRep.HLRToShape -> Acquire [Ptr TopoDS.Edge]+boundaryEdges extractor = +    fmap concat $ forM [HLRBRep.OutLine, HLRBRep.Sharp, HLRBRep.Rg1Line] $ \lt -> do+        compoundOfEdges <- HLRBRep.HLRToShape.compoundOfEdges +            extractor lt True False+        traverse buildEdgeCurve3D =<< allEdges compoundOfEdges -instance Semigroup RawDiagram where-    a <> b = RawDiagram $ \lt v is3D -> (<>) <$> runDiagram a lt v is3D <*> runDiagram b lt v is3D+calcFuzzyTolerance :: [Ptr TopoDS.Edge] -> Acquire Double+calcFuzzyTolerance edges = do+    theBox <- Bnd.Box.new+    forM_ edges $ \e -> do+        liftIO $ BRepBndLib.addOptimal (upcast e) theBox True False -instance Monoid RawDiagram where-    mempty = RawDiagram $ \_ _ _ -> pure []+    lo <- liftIO . gpPntToV3 =<< Bnd.Box.cornerMin theBox+    hi <- liftIO . gpPntToV3 =<< Bnd.Box.cornerMax theBox+    let d = hi - lo+    let maxDim = max (d ^. _x) (d ^. _y)+    return (maxDim / 10000)++calcRayBound :: Ptr TopoDS.Shape -> Acquire Double+calcRayBound s = do+    theBox <- Bnd.Box.new+    liftIO $ BRepBndLib.addOptimal s theBox True False++    lo <- liftIO . gpPntToV3 =<< Bnd.Box.cornerMin theBox+    hi <- liftIO . gpPntToV3 =<< Bnd.Box.cornerMax theBox+    return ( 2 * (norm lo + norm hi))++-- recursively drop edges with a free end+pruneDangling :: [Ptr TopoDS.Edge] -> Acquire [Ptr TopoDS.Edge]+pruneDangling edges = do+    withVertices <- forM edges $ \e -> do+        (e, ) <$> allSubShapesWithCopy ShapeEnum.Vertex (upcast e)+    let loop current = do+            vertexIndex <- liftIO $ ShapeMap.fromList (zip (concatMap snd current) [0 :: Int ..])+            labelled <- forM current $ \(e, vs) ->+                fmap (e, vs,) . liftIO $ traverse (fmap (fromMaybe (-1)) . ShapeMap.lookup vertexIndex) vs+            let weight labels = if length labels == 1 then 2 else 1 :: Int+                counts = IntMap.fromListWith (+) [(l, weight labels) | (_, _, labels) <- labelled, l <- labels]+                keep = [ (e, vs) | (e, vs, labels) <- labelled, all (\l -> IntMap.findWithDefault 0 l counts >= 2) labels ]+            if length keep == length current then pure (fst <$> keep) else loop keep+    loop withVertices++mergeRegions :: [Ptr TopoDS.Face] -> Acquire [Shape]+mergeRegions [] = pure []+mergeRegions [s] = liftIO $ pure . Shape <$> fromAcquirePtr (TopoDS.Shape.copy . upcast $ s)+mergeRegions regions = do+    builder <- TopoDS.Builder.new+    compound <- TopoDS.Compound.new+    liftIO $ TopoDS.Builder.makeCompound builder compound+    forM_ regions $ liftIO . TopoDS.Builder.add builder (upcast compound) . upcast+    unifier <- UnifySameDomain.fromShape (upcast compound) False True False+    liftIO $ UnifySameDomain.build unifier+    sameDomain <- UnifySameDomain.shape unifier+    liftIO . fmap (fmap Shape) . fromAcquirePtrT $ allSubShapesWithCopy ShapeEnum.Face sameDomain++faceArea :: Ptr TopoDS.Face -> Acquire Double+faceArea face = do+    props <- GProps.new+    liftIO $ BRepGProp.surfaceProperties (upcast face) props False False+    liftIO $ GProps.mass props++buildSolidDiagramFills' +    :: Ptr TopoDS.Shape+    -> V3 Double +    -> Ptr HLRAlgo.Projector+    -> Ptr HLRBRep.HLRToShape+    -> [(Ptr TopoDS.Face, Paint)]+    -> Acquire [(Paint, Shape)]+buildSolidDiagramFills' s projectionDir projector extractor paints = do+    boundary <- boundaryEdges extractor+    if null boundary +        then return []+        else do+            tolerance <- calcFuzzyTolerance boundary +            rayBound <- calcRayBound s+            let angularTolerance = 1e-8+            fuser <- BOPAlgo.Builder.new +            liftIO $ BOPAlgo.Builder.setFuzzyValue fuser tolerance+            forM_ boundary (liftIO . BOPAlgo.Builder.addArgument fuser . upcast)+            liftIO $ BOPAlgo.Builder.perform fuser+            keptEdges <- pruneDangling +                =<< traverse (liftIO . unsafeDowncast)+                =<<  allSubShapesWithCopy ShapeEnum.Edge +                =<< BOPAlgo.Builder.shape fuser++            builder <- TopoDS.Builder.new+            compound <- TopoDS.Compound.new+            liftIO $ TopoDS.Builder.makeCompound builder compound+            forM_ keptEdges $ liftIO . TopoDS.Builder.add builder (upcast compound) . upcast++            wires <- TopoDS.Shape.new+            status <- liftIO $ BOPAlgo.Tools.edgesToWires (upcast compound) wires True angularTolerance+            if status /= 0+                then pure [] +                else do+                    faces <- TopoDS.Shape.new+                    ok <- liftIO $ BOPAlgo.Tools.wiresToFaces wires faces angularTolerance+                    if not ok+                        then return [] +                        else do+                            regions <- traverse (liftIO . unsafeDowncast)+                                 =<< allSubShapesWithCopy ShapeEnum.Face faces++                            inv <- Projector.invertedTransformation projector+                            intersector <- ShapeIntersector.new+                            liftIO $ ShapeIntersector.load intersector s (tolerance/1000)++                            paintMap <- liftIO $ ShapeMap.fromList (first upcast <$> paints)+                            +                            d <- v3ToDir projectionDir++                            forwardFacingRegions <- filterM (fmap (> 0) . faceArea) regions+                            paintRegionMap <- fmap (M.fromListWith (<>) . catMaybes) $ forM forwardFacingRegions $ \region -> do+                                mesh <- IncrementalMesh.fromShapeAndLinDeflection (upcast region) tolerance+                                liftIO $ IncrementalMesh.perform mesh+                                loc <- TopLoc.Location.new+                                props <- GProps.new+                                liftIO $ BRepGProp.surfaceProperties (upcast region) props False False +                                tri <- BRep.Tool.triangulation region loc+                                nullTriangulation <- liftIO $ Poly.Triangulation.isNull tri+                                nTri <- if nullTriangulation then pure 0 else liftIO $ Poly.Triangulation.nbTriangles tri++                                triangleCenters <- forM [1..nTri] $ \i -> do +                                    t <- Poly.Triangulation.triangle tri i+                                    indices <- traverse (liftIO . Poly.Triangle.value t) [1, 2, 3]+                                    corners <- traverse (liftIO . gpPntToV3 <=< Poly.Triangulation.node tri) indices+                                    pure (sum corners / 3)+                                centerOfMass <- liftIO . gpPntToV3 =<< GProps.centreOfMass props+                                let candidatePoints = (triangleCenters <> [centerOfMass])+                                        & (traverse . _z .~ 0)++                                let lookupCandidatePaint [] = pure Nothing+                                    lookupCandidatePaint (h:t) = do+                                        pin <- v3ToPnt h+                                        p <- GP.Pnt.transformed pin inv+                                        line <- GP.Lin.new p d+                                        liftIO $ ShapeIntersector.perform intersector line (-rayBound) rayBound+                                        +                                        n <- liftIO $ ShapeIntersector.nbPnt intersector+                                        hits <- forM [1 .. n] $ \i -> (, i) <$> liftIO (ShapeIntersector.wParameter intersector i)+                                        case hits of+                                            [] -> lookupCandidatePaint t+                                            _ -> do+                                                let (_, nearest) = maximum hits+                                                hit <- ShapeIntersector.face intersector nearest+                                                found <- liftIO $ ShapeMap.lookup paintMap (upcast hit)+                                                return $ Just (fromMaybe mempty found)+                                paint <- lookupCandidatePaint candidatePoints+                                return $ (, [region]) <$> paint++                            traverse mergeRegions paintRegionMap+                                <&> foldMap sequence . M.toList++buildSolidDiagramFills+    :: PaintMap +    -> Ptr TopoDS.Shape +    -> V3 Double+    -> Ptr HLRAlgo.Projector+    -> Ptr HLRBRep.HLRToShape+    -> Acquire [(Paint, Shape)]+buildSolidDiagramFills paints s d projector extractor+    | paintMapIsEmpty paints = pure []+    | otherwise =    +        buildSolidDiagramFills' s d projector extractor+        =<< materialiseFacePaints s paints 

@@ -2,6 +2,7 @@ ( edgeEndpoints , edgeValue , wireEndpoints+, allSubShapesWithCopy , allWireEndpoints , allWires , allEdges@@ -25,7 +26,6 @@ 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 Waterfall.Internal.NearZero (nearZero)@@ -44,6 +44,8 @@ import Waterfall.Internal.ToOpenCascade (v3ToPnt) import Data.Foldable (traverse_) import OpenCascade.Inheritance (upcast, unsafeDowncast)+import qualified Waterfall.Internal.ShapeMap as ShapeMap+import qualified OpenCascade.TopAbs.Orientation as TopAbs.Orientation  edgeEndpoints :: Ptr TopoDS.Edge -> IO (V3 Double, V3 Double) edgeEndpoints edge = (`with` pure) $ do@@ -65,33 +67,34 @@ allWireEndpoints :: Ptr TopoDS.Wire -> IO [(V3 Double, V3 Double)] allWireEndpoints wire = with (WireExplorer.fromWire wire) $ \explorer -> do     let runToEnd = do-            edge <- WireExplorer.current explorer-            points <- edgeEndpoints edge-            WireExplorer.next explorer             more <- WireExplorer.more explorer-            if more -                then (points:) <$> runToEnd-                else pure [points]+            if more then do+                edge <- WireExplorer.current explorer+                points <- edgeEndpoints edge+                WireExplorer.next explorer+                (points:) <$> runToEnd+            else pure []     runToEnd  allSubShapesWithCopy :: ShapeEnum.ShapeEnum -> Ptr TopoDS.Shape -> Acquire [Ptr TopoDS.Shape] allSubShapesWithCopy t s = do      explorer <- Explorer.new s t-    let go visited = do+    let go acc = 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+                    isPresent <- liftIO $ ShapeMap.lookup acc v+                    (newAcc, add) <- case isPresent of +                        Nothing -> do                              v' <- TopoDS.Shape.copy v-                            return (v':) +                            newMap <- liftIO $ ShapeMap.addIfAbsent (v', ()) acc+                            return (newMap, (v':))+                        Just _ -> pure (acc, id)                      liftIO $ Explorer.next explorer-                    add <$> go visited+                    add <$> go newAcc                 else return []-    go []+    go ShapeMap.empty   allEdges :: Ptr TopoDS.Shape -> Acquire [Ptr TopoDS.Edge]@@ -146,13 +149,18 @@ 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']+            if not more+                then pure []+                else do+                    edge <- liftIO $ WireExplorer.current explorer+                    edge' <- (liftIO . unsafeDowncast) =<< TopoDS.Shape.copy (upcast edge)+                    orientation <- liftIO $ TopoDS.Shape.orientation (upcast edge')+                    edge'' <- if orientation == TopAbs.Orientation.Reversed+                        then reverseEdge edge'+                        else return edge'+                    liftIO $ WireExplorer.next explorer+                    (edge'' :) <$> runToEnd     runToEnd  reverseWire :: Ptr TopoDS.Wire -> Acquire (Ptr TopoDS.Wire) @@ -160,12 +168,13 @@     explorer <- WireExplorer.fromWire wire     makeWire <- MakeWire.new     let runToEnd = do-            edge <- liftIO $ WireExplorer.current explorer-            edge' <- reverseEdge edge-            liftIO $ WireExplorer.next explorer             more <- liftIO $ WireExplorer.more explorer-            when more runToEnd-            liftIO $ MakeWire.addEdge makeWire edge'+            when more $ do+                edge <- liftIO $ WireExplorer.current explorer+                edge' <- reverseEdge edge+                liftIO $ WireExplorer.next explorer+                runToEnd+                liftIO $ MakeWire.addEdge makeWire edge'     runToEnd     MakeWire.wire makeWire 

@@ -1,64 +1,76 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, PolyKinds, UndecidableInstances, StandaloneKindSignatures #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-} {-|  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. +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+( -- * Pointer valued resources + unsafeFromAcquirePtr+, unsafeFromAcquirePtrWithCatch+, unsafeFromAcquirePtrT+, unsafeFromAcquirePtrTWithCatch+, fromAcquirePtr+, fromAcquirePtrT+, acquireForeignPtr+-- * Pure valued resources+, runAcquire+, unsafeFromAcquire , unsafeFromAcquireWithCatch-, unsafeFromAcquireT-, unsafeFromAcquireTWithCatch-, fromAcquire-, fromAcquireT-, toAcquire+-- * Type Family+, NoPtr ) 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 Data.Acquire (Acquire, mkAcquire, allocateAcquire, with) import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromMaybe) import Control.Monad (forM, when) import Data.IORef (newIORef, atomicModifyIORef)-import Control.Exception (try)+import Control.Exception (try, evaluate) import Control.Arrow (left)-import OpenCascade.Internal.Exception (OpenCascadeException) import Waterfall.Error (WaterfallError (..))+import Foreign.Ptr (Ptr)+import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import qualified Foreign.Concurrent as Concurrent+import Control.DeepSeq (NFData, force)+import Data.Kind (Constraint)+import GHC.TypeLits (TypeError, ErrorMessage (..)) --- | 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++-- | Convert a resource in the @Data.Acquire.Acquire@ monad to a @ForeignPtr@ in @IO@+--+-- the @free@ action of the resource is called when the @ForeignPtr@ is garbage collected, -- so may run at an unpredictable time.-fromAcquire :: Acquire a -> IO a -fromAcquire a = runResourceT $ do-    (releaseKey, v) <- allocateAcquire a+fromAcquirePtr :: Acquire (Ptr a) -> IO (ForeignPtr a)+fromAcquirePtr a = runResourceT $ do+    (releaseKey, ptr) <- allocateAcquire a     release <- fromMaybe (pure ()) <$> unprotect releaseKey-    liftIO $ addFinalizer v release-    return v-+    liftIO $ Concurrent.newForeignPtr ptr release     --- | 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--- 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+-- | variant of `fromAcquirePtr` for a resource of a container of pointers+-- +-- the free action of the resource is called once every @ForeignPtr@ in the container has been garbage collected+fromAcquirePtrT :: Traversable f => Acquire (f (Ptr a)) -> IO (f (ForeignPtr a)) +fromAcquirePtrT a = runResourceT $ do+    (releaseKey, ptrs) <- allocateAcquire a     release <- fromMaybe (pure ()) <$> unprotect releaseKey-    ref <- liftIO $ newIORef (length v)+    ref <- liftIO $ newIORef (length ptrs)     let finalize = do             isLast <- atomicModifyIORef ref (\count -> (count - 1, count == 1))             when isLast release-            -    forM v $ \v' -> do -        liftIO $ addFinalizer v' finalize-        return v'+    liftIO $ when (null ptrs) release+    forM ptrs $ \ptr -> do +        liftIO $ Concurrent.newForeignPtr ptr finalize  -- | 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.@@ -67,28 +79,70 @@ -- -- 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+{-# NOINLINE unsafeFromAcquirePtr #-}+unsafeFromAcquirePtr :: Acquire (Ptr a) -> ForeignPtr a+unsafeFromAcquirePtr = unsafePerformIO . fromAcquirePtr  -- | Version of `unsafeFromAcquire` which returns a `WaterfallError` if the action throws-{-# NOINLINE unsafeFromAcquireWithCatch #-}-unsafeFromAcquireWithCatch :: Acquire a -> Either WaterfallError a-unsafeFromAcquireWithCatch = -    left WaterfallError . unsafePerformIO . try . fromAcquire+{-# NOINLINE unsafeFromAcquirePtrWithCatch #-}+unsafeFromAcquirePtrWithCatch :: Acquire (Ptr a) -> Either WaterfallError (ForeignPtr a)+unsafeFromAcquirePtrWithCatch = +    left WaterfallError . unsafePerformIO . try . fromAcquirePtr --- | 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+-- | Version of `unsafeFromAcquirePtr`  which operates on a container of pointers+{-# NOINLINE unsafeFromAcquirePtrT #-}+unsafeFromAcquirePtrT :: (Traversable t) => Acquire (t (Ptr a))  -> t (ForeignPtr a)+unsafeFromAcquirePtrT = unsafePerformIO . fromAcquirePtrT +-- | Version of `unsafeFromAcquirePtrWithCatch`  which registers the finalizer on a container of pointers +{-# NOINLINE unsafeFromAcquirePtrTWithCatch #-}+unsafeFromAcquirePtrTWithCatch :: (Traversable t) => Acquire (t (Ptr a))  -> Either WaterfallError (t (ForeignPtr a))+unsafeFromAcquirePtrTWithCatch = left WaterfallError . unsafePerformIO . try . fromAcquirePtrT --- | Version of `unsafeFromAcquireWithCatch`  which registers the finalizer on the _value_ in a container -{-# NOINLINE unsafeFromAcquireTWithCatch #-}-unsafeFromAcquireTWithCatch :: (Traversable t) => Acquire (t a)  -> Either WaterfallError (t a)-unsafeFromAcquireTWithCatch = left WaterfallError . unsafePerformIO . try . fromAcquireT+-- | Borrow the pointer held by a `ForeignPtr` for the duration of an `Acquire`+-- +-- The `ForeignPtr` is kept alive (it's finalizer isn't run) until the resource is released.+acquireForeignPtr :: ForeignPtr a -> Acquire (Ptr a)+acquireForeignPtr fp =+    mkAcquire +        (pure . unsafeForeignPtrToPtr $ fp)+        (const (touchForeignPtr fp)) --- | 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+-- | calling the pure valued functions with a pointer type would almost certainly be a bug+-- +-- @Ptr@ has an @NFData@ instance, so if we _only_ used that constraint, the functions could be applied to pointers+--+-- Defining a type family for "things that aren't pointers" lets us check that we aren't acquiring pointers+type NoPtr :: k -> Constraint+type family NoPtr a where+    NoPtr (Ptr a) = TypeError ('Text "unsafeFromAcquire can't return a " ':<>: 'ShowType (Ptr a) ':$$: 'Text " use unsafeFromAcquirePtr instead")+    NoPtr (ForeignPtr a) = TypeError ('Text "unsafeFromAcquire can't return a " ':<>: 'ShowType (ForeignPtr a) ':$$: 'Text " use unsafeFromAcquirePtr instead")+    NoPtr (f a) = (NoPtr f, NoPtr a)+    NoPtr _ = ()++-- | Run a resource in the `Data.Acquire.Acquire` monad to completion,+-- fully evaluating its result before the resource is released.+--+-- Because the result is forced with `force`, it shouldn't hold on to anything inside the resource,+-- making it safe to release the resource immediately.+runAcquire :: (NFData a, NoPtr a) => Acquire a -> IO a+runAcquire a = with a (evaluate . force)+++-- | Run a resource in the `Data.Acquire.Acquire` monad, returning its (fully evaluated) result as a pure 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 resource is released as soon as the result has been computed.+-- If the result needs to hold a pointer into the resource, use `unsafeFromAcquirePtr` instead.+{-# NOINLINE unsafeFromAcquire #-}+unsafeFromAcquire :: (NFData a, NoPtr a) => Acquire a -> a+unsafeFromAcquire = unsafePerformIO . runAcquire++-- | Version of `unsafeFromAcquire` which returns a `WaterfallError` if the action throws+{-# NOINLINE unsafeFromAcquireWithCatch #-}+unsafeFromAcquireWithCatch :: (NFData a, NoPtr a) => Acquire a -> Either WaterfallError a+unsafeFromAcquireWithCatch = +    left WaterfallError . unsafePerformIO . try . runAcquire

@@ -2,14 +2,21 @@ ( gpPntToV3 , gpVecToV3 , gpXYZToV3+, shapesFromListOfShape ) 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 qualified OpenCascade.NCollection as NCollection+import qualified OpenCascade.NCollection.List as NCollection.List+import qualified OpenCascade.NCollection.List.Iterator as NCollection.List.Iterator+import qualified OpenCascade.TopoDS as TopoDS  import Linear (V3 (..)) import Foreign.Ptr+import Data.Acquire (Acquire)+import Control.Monad.IO.Class (liftIO)      gpPntToV3 :: Ptr GP.Pnt -> IO (V3 Double) gpPntToV3 pnt = V3 <$> GP.Pnt.getX pnt <*> GP.Pnt.getY pnt <*> GP.Pnt.getZ pnt@@ -19,3 +26,17 @@  gpXYZToV3 :: Ptr GP.XYZ -> IO (V3 Double) gpXYZToV3 xyz = V3 <$> GP.XYZ.x xyz <*> GP.XYZ.y xyz <*> GP.XYZ.z xyz+++shapesFromListOfShape :: Ptr (NCollection.List TopoDS.Shape) -> Acquire [Ptr TopoDS.Shape]+shapesFromListOfShape list = do+    iterator <- NCollection.List.Iterator.newListOfShapeIterator list+    let go = do+            more <- liftIO $ NCollection.List.Iterator.moreListOfShapeIterator iterator+            if more+                then do+                    value <- NCollection.List.Iterator.valueListOfShapeIterator iterator+                    liftIO $ NCollection.List.Iterator.nextListOfShapeIterator iterator+                    (value :) <$> go+                else pure []+    go

@@ -0,0 +1,77 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+module Waterfall.Internal.PaintHistory+( remapWithBlendFunction+) where++import qualified OpenCascade.TopoDS.Types as TopoDS+import Foreign.Ptr (Ptr)+import Data.Acquire (Acquire)+import Waterfall.Paint (Paint)+import Control.Monad.IO.Class (liftIO)+import Waterfall.Internal.Solid (remapPaints, History (historyGenerated), fromAcquirePaints, PaintMap (FacePaints, UniformPaint), materialiseFacePaints, acquireFacePaints)+import OpenCascade.Inheritance (SubTypeOf(upcast), unsafeDowncast)+import qualified OpenCascade.NCollection as NCollection+import qualified Waterfall.Internal.ShapeMap as ShapeMap+import Waterfall.Internal.Edges (allSubShapesWithCopy)+import Data.Foldable (toList)+import qualified OpenCascade.NCollection.IndexedDataMap as NCollection.IndexedDataMap+import qualified OpenCascade.TopExp as TopExp+import Control.Arrow (first)+import Data.Maybe (catMaybes)+import qualified Data.List.NonEmpty as NE+import qualified OpenCascade.TopAbs.ShapeEnum as ShapeEnum+import qualified OpenCascade.TopoDS.Shape as TopoDS.Shape+import Control.Monad (filterM)+import Waterfall.Internal.FromOpenCascade (shapesFromListOfShape)++getUniqueVertexes :: [Ptr TopoDS.Edge] -> Acquire [Ptr TopoDS.Vertex]+getUniqueVertexes edges = +    let vertsForEdge e = traverse (liftIO . unsafeDowncast) =<< allSubShapesWithCopy ShapeEnum.Vertex (upcast e)+        dup a = (upcast a, a)+        in fmap toList . liftIO . ShapeMap.fromList . fmap dup . concat  =<< traverse vertsForEdge edges++makeAncestorMap :: Ptr TopoDS.Shape -> Acquire (Ptr (NCollection.IndexedDataMap TopoDS.Shape (NCollection.List TopoDS.Shape)))+makeAncestorMap s = do+    m <- NCollection.IndexedDataMap.newShapeListOfShapeMap+    liftIO $ TopExp.mapShapesAndAncestors s ShapeEnum.Edge ShapeEnum.Face m+    liftIO $ TopExp.mapShapesAndAncestors s ShapeEnum.Vertex ShapeEnum.Face m+    return m++remapWithBlendFunction' :: (NE.NonEmpty Paint -> Paint) -> Ptr TopoDS.Shape -> [Ptr TopoDS.Edge] -> History -> [(Ptr TopoDS.Face, Paint)] -> Acquire PaintMap+remapWithBlendFunction' paintFunction s edges history paints = do+    mappedPaints <- liftIO $ remapPaints history paints++    ancestorMap <- makeAncestorMap s+    paintMap <- liftIO $ ShapeMap.fromList (fmap (first upcast) paints)++    let filletSurfacesFor :: Ptr TopoDS.Shape -> Acquire [(Ptr TopoDS.Face, Paint)]+        filletSurfacesFor edge = do+            faces <- liftIO . filterM (fmap (== ShapeEnum.Face) . TopoDS.Shape.shapeType)+                =<< shapesFromListOfShape +                =<< historyGenerated history edge+            if null faces then pure [] else do+                neighbours <- shapesFromListOfShape =<<+                    NCollection.IndexedDataMap.findFromKeyShapeListOfShapeMap ancestorMap edge+                neighbouringPaints <- liftIO . fmap catMaybes $ traverse (ShapeMap.lookup paintMap) neighbours+                case NE.nonEmpty neighbouringPaints of +                    Nothing -> pure []+                    Just ps -> +                        let newPaint = paintFunction (NE.nub . NE.sort $ ps)+                        in traverse (fmap (, newPaint) . liftIO . unsafeDowncast) faces++    filletSurfacesEdges <- liftIO . fromAcquirePaints $ concat <$> traverse (filletSurfacesFor . upcast) edges+    verts <- getUniqueVertexes edges+    filletSurfacesVerts <-liftIO . fromAcquirePaints $ concat <$> traverse (filletSurfacesFor . upcast) verts++    return $ FacePaints (mappedPaints <> filletSurfacesEdges <> filletSurfacesVerts)+++remapWithBlendFunction :: (NE.NonEmpty Paint -> Paint) -> Ptr TopoDS.Shape -> [Ptr TopoDS.Edge] -> History -> PaintMap -> Acquire PaintMap+remapWithBlendFunction paintFunction s edges history (FacePaints paints) = +    remapWithBlendFunction' paintFunction s edges history =<< acquireFacePaints paints+remapWithBlendFunction paintFunction s edges history (UniformPaint paint) +    | paintFunction (NE.singleton paint) == paint = pure $ UniformPaint paint+    | otherwise = remapWithBlendFunction' paintFunction s edges history =<< materialiseFacePaints s (UniformPaint paint) +

@@ -5,23 +5,25 @@ , allPathEndpoints ) where -import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire) +import Waterfall.Internal.Finalizers (acquireForeignPtr, unsafeFromAcquire)  import Control.Monad.IO.Class (liftIO) import Linear (V3 (..)) import Waterfall.Internal.Path.Common (RawPath (..)) import Waterfall.Internal.Edges (allWireEndpoints)+import Control.DeepSeq (NFData) -- | A Path in 3D Space  -- -- Under the hood, this is represented by an OpenCascade `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+newtype Path = Path { rawPath :: RawPath } +    deriving (Semigroup, Monoid, NFData) via RawPath  -- | Exposing this because I found it useful for debugging allPathEndpoints :: Path -> [(V3 Double, V3 Double)] allPathEndpoints (Path (ComplexRawPath raw)) = unsafeFromAcquire $ do-    wire <- toAcquire raw+    wire <- acquireForeignPtr raw     liftIO $ allWireEndpoints wire allPathEndpoints (Path (SinglePointRawPath point)) = pure (point, point) allPathEndpoints (Path EmptyRawPath) = []

@@ -11,22 +11,29 @@ 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 Waterfall.Internal.Finalizers (acquireForeignPtr, unsafeFromAcquirePtrT) import Control.Monad.IO.Class (liftIO) import Linear (V3 (..), distance) import Foreign.Ptr-import Data.Maybe (catMaybes)+import Foreign.ForeignPtr (ForeignPtr)+import Data.Maybe (mapMaybe) import Data.Semigroup (sconcat) import Data.List.NonEmpty (NonEmpty ()) import Data.Foldable (toList)+import Control.DeepSeq (NFData (rnf), rwhnf) -data RawPath = EmptyRawPath | SinglePointRawPath (V3 Double) | ComplexRawPath (Ptr TopoDS.Wire)+data RawPath = EmptyRawPath | SinglePointRawPath (V3 Double) | ComplexRawPath (ForeignPtr TopoDS.Wire) -rawPathWire :: RawPath -> Maybe (Ptr TopoDS.Wire)-rawPathWire (ComplexRawPath wire) = Just wire-rawPathWire _ = Nothing+instance NFData RawPath where+    rnf EmptyRawPath = ()+    rnf (SinglePointRawPath v) = rnf v+    rnf (ComplexRawPath fp) = rwhnf fp -rawPathToEither :: RawPath -> Maybe (Either (V3 Double) (Ptr TopoDS.Wire))+rawPathWire :: RawPath -> Acquire (Maybe (Ptr TopoDS.Wire))+rawPathWire (ComplexRawPath wire) = Just <$> acquireForeignPtr wire+rawPathWire _ = pure Nothing++rawPathToEither :: RawPath -> Maybe (Either (V3 Double) (ForeignPtr TopoDS.Wire)) rawPathToEither EmptyRawPath = Nothing rawPathToEither (SinglePointRawPath p) = Just . Left $ p rawPathToEither (ComplexRawPath wire) = Just . Right $ wire@@ -48,8 +55,7 @@     ea <- case a of              Left pnt -> pure pnt             Right wire -> do-                wire' <- toAcquire wire-                liftIO $ snd <$> wireEndpoints wire'+                liftIO $ snd <$> wireEndpoints wire     sb <- case b of             Left pnt -> pure pnt              Right wire -> liftIO $ fst <$> wireEndpoints wire@@ -60,14 +66,17 @@  joinRawPaths :: [RawPath] -> RawPath joinRawPaths paths = -    case catMaybes (rawPathToEither <$> paths) of+    case mapMaybe 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+        path@(h:_) ->+            let joined = unsafeFromAcquirePtrT $ do+                    acquired <- traverse (traverse acquireForeignPtr) path+                    interspersed <- intersperseLines acquired+                    case interspersed of +                        [] -> pure Nothing+                        wires -> Just <$> joinWires wires+            in maybe (either SinglePointRawPath ComplexRawPath h) ComplexRawPath joined  instance Semigroup RawPath where     sconcat :: NonEmpty RawPath -> RawPath

@@ -0,0 +1,51 @@+{-# LANGUAGE DeriveTraversable #-}+module Waterfall.Internal.ShapeMap+( ShapeMap+, lookup+, fromList+, addIfAbsent+, empty+) where+import Prelude hiding (lookup)+import qualified OpenCascade.TopoDS as TopoDS+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Foreign.Ptr (Ptr)+import qualified OpenCascade.TopTools.ShapeMapHasher as TopTools.ShapeMapHasher+import qualified OpenCascade.TopoDS.Shape as TopoDS.Shape+import Control.Monad (forM, join)++newtype ShapeMap a = ShapeMap +    { getInternalMap :: IntMap [(Ptr TopoDS.Shape, a)] +    } deriving (Functor, Foldable, Traversable)++empty :: ShapeMap a+empty = ShapeMap mempty++ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM b t f = do b' <- b; if b' then t else f++findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)+findM p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing)++lookupList :: Ptr TopoDS.Shape -> [(Ptr TopoDS.Shape, a)] -> IO (Maybe a)+lookupList s = fmap (fmap snd) . findM (TopoDS.Shape.isSame s . fst) ++lookup :: ShapeMap a -> Ptr TopoDS.Shape -> IO (Maybe a)+lookup (ShapeMap hashMap) s = do+    hash <- TopTools.ShapeMapHasher.hash s+    fmap join . forM (IntMap.lookup hash hashMap) $ lookupList s++fromList :: [(Ptr TopoDS.Shape, a)] -> IO (ShapeMap a)+fromList = foldr (\value -> (addIfAbsent value =<<)) (pure empty)++addIfAbsent :: (Ptr TopoDS.Shape, a) -> ShapeMap a -> IO (ShapeMap a)+addIfAbsent (s, v) (ShapeMap hashMap) = do +    hash <- TopTools.ShapeMapHasher.hash s+    let update Nothing = pure (Just [(s, v)])+        update (Just vs) = do+            r <- lookupList s vs+            return $ case r of +                Nothing -> Just ((s, v): vs)+                Just _ -> Just vs+    ShapeMap <$> IntMap.alterF update hash hashMap 

@@ -1,11 +1,28 @@ {-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DerivingVia #-} module Waterfall.Internal.Solid  ( Solid (..)+, PaintMap (..)+, History (..)+, emptyPaintMap+, paintMapIsEmpty , acquireSolid+, fromAcquirePaints+, acquireFacePaints , solidFromAcquire , solidFromAcquireWithCatch , solidFromAcquireTWithCatch+, solidFromAcquireMappingPaintMap+, solidFromAcquireWithPaintMapWithCatch+, solidFromAcquireTWithPaintMapWithCatch+, solidFromAcquireMappingPaintMapWithCatch+, remapPaints+, materialiseFacePaints+, makeShapeHistory+, bopBuilderHistory , union3D , difference3D , intersection3D@@ -26,15 +43,42 @@ import qualified OpenCascade.BRepAlgoAPI.Cut as Cut import qualified OpenCascade.BRepAlgoAPI.Common as Common import qualified OpenCascade.BRepBuilderAPI.MakeSolid as MakeSolid+import OpenCascade.BRepBuilderAPI (MakeShape)+import qualified OpenCascade.BRepBuilderAPI.MakeShape as MakeShape import qualified OpenCascade.BOPAlgo.Operation as BOPAlgo.Operation import qualified OpenCascade.BOPAlgo.BOP as BOPAlgo.BOP import qualified OpenCascade.BOPAlgo.Builder as BOPAlgo.Builder-import OpenCascade.Inheritance (upcast)-import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire, unsafeFromAcquireWithCatch, unsafeFromAcquireTWithCatch)+import qualified OpenCascade.TopAbs.ShapeEnum as ShapeEnum+import OpenCascade.Inheritance (SubTypeOf(..), upcast, unsafeDowncast)+import Waterfall.Internal.Finalizers (acquireForeignPtr, fromAcquirePtrT, unsafeFromAcquire, unsafeFromAcquirePtr, unsafeFromAcquirePtrTWithCatch, unsafeFromAcquirePtrWithCatch, unsafeFromAcquirePtrT)+import Waterfall.Internal.Edges (allSubShapesWithCopy) import qualified OpenCascade.BOPAlgo.Builder as BOPAlgo import Data.Foldable (traverse_)+import Data.Bifunctor.Flip (Flip (..)) import Waterfall.Error (WaterfallError)+import Waterfall.Paint (Paint, paintIsDefined)+import Data.Functor.Compose (Compose(..))+import qualified OpenCascade.NCollection as NCollection+import Control.Monad (filterM)+import Waterfall.Internal.FromOpenCascade (shapesFromListOfShape)+import Foreign.ForeignPtr (ForeignPtr)+import Control.DeepSeq (NFData (rnf), liftRnf, liftRnf2, rwhnf) +data PaintMap +    = UniformPaint Paint+    | FacePaints [(ForeignPtr TopoDS.Face, Paint)]++instance NFData PaintMap where +    rnf (UniformPaint p) = rnf p+    rnf (FacePaints fs) = liftRnf (liftRnf2 rwhnf rnf) fs++emptyPaintMap :: PaintMap+emptyPaintMap = UniformPaint mempty++paintMapIsEmpty :: PaintMap -> Bool+paintMapIsEmpty (UniformPaint p) = not $ paintIsDefined p+paintMapIsEmpty _ = False+  -- | The Boundary Representation of a solid object. -- -- Alternatively, a region of 3d Space.@@ -44,25 +88,46 @@ --  -- 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 { rawSolid :: Ptr TopoDS.Shape.Shape }+-- where this isn't the case (without using internal functions).+data Solid = Solid +    { rawSolid :: ForeignPtr TopoDS.Shape.Shape +    , solidPaintMap :: PaintMap+    } +instance NFData Solid where+    rnf (Solid s paints) = rwhnf s `seq` rnf paints+ acquireSolid :: Solid -> Acquire (Ptr TopoDS.Shape.Shape)-acquireSolid (Solid ptr) = toAcquire ptr+acquireSolid (Solid ptr _) = acquireForeignPtr ptr -solidFromAcquire :: Acquire (Ptr TopoDS.Shape.Shape) -> Solid-solidFromAcquire = Solid . unsafeFromAcquire+solidFromAcquire :: PaintMap -> Acquire (Ptr TopoDS.Shape.Shape) -> Solid+solidFromAcquire paintMap = (`Solid` paintMap) . unsafeFromAcquirePtr -solidFromAcquireWithCatch :: Acquire (Ptr TopoDS.Shape.Shape) -> Either WaterfallError Solid-solidFromAcquireWithCatch = fmap Solid . unsafeFromAcquireWithCatch+solidFromAcquireWithPaintMap ::  Acquire (PaintMap, Ptr TopoDS.Shape.Shape) -> Solid+solidFromAcquireWithPaintMap f = +    let (paintMap, ptr) = unsafeFromAcquirePtrT f +    in Solid ptr paintMap -solidFromAcquireTWithCatch :: Traversable t => Acquire (t (Ptr TopoDS.Shape.Shape)) -> Either WaterfallError (t Solid)-solidFromAcquireTWithCatch = fmap (fmap Solid) . unsafeFromAcquireTWithCatch+solidFromAcquireWithPaintMapWithCatch ::  Acquire (PaintMap, Ptr TopoDS.Shape.Shape) -> Either WaterfallError Solid+solidFromAcquireWithPaintMapWithCatch f = do+    (paintMap, ptr) <- unsafeFromAcquirePtrTWithCatch f +    return $ Solid ptr paintMap +    +solidFromAcquireTWithPaintMapWithCatch :: Traversable t => Acquire (t (PaintMap, Ptr TopoDS.Shape.Shape)) -> Either WaterfallError (t Solid)+solidFromAcquireTWithPaintMapWithCatch = +    fmap (fmap (uncurry (flip Solid)) . getCompose) . unsafeFromAcquirePtrTWithCatch . fmap Compose++solidFromAcquireWithCatch :: PaintMap -> Acquire (Ptr TopoDS.Shape.Shape) -> Either WaterfallError Solid+solidFromAcquireWithCatch paintMap = fmap (`Solid` paintMap) . unsafeFromAcquirePtrWithCatch++solidFromAcquireTWithCatch :: Traversable t => PaintMap -> Acquire (t (Ptr TopoDS.Shape.Shape)) -> Either WaterfallError (t Solid)+solidFromAcquireTWithCatch paintMap  = fmap (fmap (`Solid` paintMap)) . unsafeFromAcquirePtrTWithCatch+ -- | print debug information about a Solid when it's evaluated  -- exposes the properties of the underlying OpenCacade.TopoDS.Shape debug :: Solid -> String-debug (Solid ptr) = +debug (Solid ptr _) =      let          fshow :: Show a => IO a -> IO String          fshow = fmap show@@ -81,7 +146,7 @@             , ("nbChildren", fshow . TopoDS.Shape.nbChildren)             ]     in unsafeFromAcquire $ do-        s <- toAcquire ptr+        s <- acquireForeignPtr ptr         liftIO $ (`foldMap` actions) $ \(actionName, value) ->                  (return $ "\t" <> actionName <> "\t\t") <> value s <> (return "\n") @@ -98,36 +163,139 @@ -- -- Be warned that @complement emptySolid@ does not appear to work correctly. complement :: Solid -> Solid-complement (Solid ptr) = Solid . unsafeFromAcquire $ TopoDS.Shape.complemented =<< toAcquire ptr+complement (Solid ptr paintMap) = (`Solid` paintMap) . unsafeFromAcquirePtr $ TopoDS.Shape.complemented =<< acquireForeignPtr ptr  -- | An empty solid -- -- Be warned that @complement emptySolid@ does not appear to work correctly. emptySolid :: Solid -emptySolid =  Solid . unsafeFromAcquire $ upcast <$> (MakeSolid.solid =<< MakeSolid.new)+emptySolid =  (`Solid` emptyPaintMap) . unsafeFromAcquirePtr $ 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 ptrA) (Solid ptrB) = Solid . unsafeFromAcquire $ do-    a <- toAcquire ptrA-    b <- toAcquire ptrB-    f a b +-- | this is used to abstract between `MakeShape` and `BOPAlgo.Builder`+data History = History +    { historyModified :: Ptr TopoDS.Shape -> Acquire (Ptr (NCollection.List TopoDS.Shape))+    , historyGenerated :: Ptr TopoDS.Shape -> Acquire (Ptr (NCollection.List TopoDS.Shape))+    , historyIsDeleted :: Ptr TopoDS.Shape -> IO Bool+    , historyResult :: Acquire (Ptr TopoDS.Shape)+    }++makeShapeHistory :: Ptr MakeShape -> History+makeShapeHistory builder =+    History +        (MakeShape.modified builder)+        (MakeShape.generated builder)+        (MakeShape.isDeleted builder)+        (MakeShape.shape builder)++bopBuilderHistory :: Ptr BOPAlgo.Builder -> History+bopBuilderHistory builder = +    History +        (BOPAlgo.Builder.modified builder)+        (BOPAlgo.Builder.generated builder)+        (BOPAlgo.Builder.isDeleted builder)+        (BOPAlgo.Builder.shape builder)++-- | for a builder, and a shape, return:+--+-- * if the shape was modified by the builder, or there were generated shapes of the same kind, return the modified/generated shapes+-- * if the shape was deleted by the builder, return nothing+-- * otherwise, return the shape+remap :: History -> Ptr TopoDS.Shape -> Acquire [Ptr TopoDS.Shape]+remap history s = do+        modified <- shapesFromListOfShape+                =<< historyModified history s+        generated <- shapesFromListOfShape+                =<< historyGenerated history s+        inputShapeType <- liftIO $ TopoDS.Shape.shapeType s+        sameTypeGenerated <- liftIO $ +            filterM (fmap (== inputShapeType) . TopoDS.Shape.shapeType) generated+        let candidates = modified <> sameTypeGenerated+        if not . null $ candidates+                then pure candidates+                else do+                    isDeleted <- liftIO $ historyIsDeleted history s+                    pure [s | not isDeleted]++fromAcquirePaints :: Acquire [(Ptr TopoDS.Face, Paint)] -> IO [(ForeignPtr TopoDS.Face, Paint)]+fromAcquirePaints paints = +    let wrap = fmap (Compose . fmap Flip)+        unwrap = fmap runFlip . getCompose+    in fmap unwrap . fromAcquirePtrT . wrap  $ paints++remapPaints :: History -> [(Ptr TopoDS.Face, Paint)] -> IO [(ForeignPtr TopoDS.Face, Paint)]+remapPaints history facePaints = +    let remapPaint (f, p) = fmap (,p) <$> (liftIO . traverse unsafeDowncast =<< remap history (upcast f))+        remappedPaints = concat <$> traverse remapPaint facePaints+    in fromAcquirePaints remappedPaints ++acquireFacePaints :: [(ForeignPtr TopoDS.Face, Paint)] -> Acquire [(Ptr TopoDS.Face, Paint)]+acquireFacePaints = +    let wrap = Compose . fmap Flip+        unwrap = fmap runFlip . getCompose+    in fmap unwrap . traverse acquireForeignPtr . wrap++materialiseFacePaints :: Ptr TopoDS.Shape -> PaintMap -> Acquire [(Ptr TopoDS.Face, Paint)]+materialiseFacePaints _ (FacePaints facePaints) = acquireFacePaints facePaints +materialiseFacePaints solid (UniformPaint paint) = do+    faces <- traverse (liftIO . unsafeDowncast)+        =<< allSubShapesWithCopy ShapeEnum.Face solid+    return $ fmap (, paint) faces++materialiseSolidFacePaints :: Solid -> Acquire [(Ptr TopoDS.Face, Paint)]+materialiseSolidFacePaints solid = do+    s <- acquireSolid solid+    materialiseFacePaints s (solidPaintMap solid)++mapPaintMap :: (PaintMap, History) -> Acquire (PaintMap, Ptr TopoDS.Shape.Shape)+mapPaintMap (paintMap, history) = do+    shape <- historyResult history++    remappedPaintMap <- case paintMap of+        UniformPaint _ -> pure paintMap+        FacePaints oldFacePaints -> +            FacePaints <$> (liftIO . remapPaints history =<< acquireFacePaints oldFacePaints)+            +    return (remappedPaintMap, shape)+++solidFromAcquireMappingPaintMap :: Acquire (PaintMap, History) -> Solid+solidFromAcquireMappingPaintMap f = +    solidFromAcquireWithPaintMap (mapPaintMap =<< f)++solidFromAcquireMappingPaintMapWithCatch :: Acquire (PaintMap, History) -> Either WaterfallError Solid+solidFromAcquireMappingPaintMapWithCatch f = +    solidFromAcquireWithPaintMapWithCatch (mapPaintMap =<< f)++toBoolean :: (SubTypeOf MakeShape a) => (Ptr TopoDS.Shape -> Ptr TopoDS.Shape -> Acquire (Ptr a)) -> Solid -> Solid -> Solid+toBoolean f (Solid ptrA paintMapA) (Solid ptrB paintMapB) = solidFromAcquireMappingPaintMap $ do+    a <- acquireForeignPtr ptrA+    b <- acquireForeignPtr ptrB+    builder <- f a b+    +    materialisedPaintMap <- case (paintMapA, paintMapB) of+        (UniformPaint paintA, UniformPaint paintB) | paintA == paintB -> pure paintMapA+        _ -> liftIO $ FacePaints <$> fromAcquirePaints (+                (<>) <$> materialiseFacePaints a paintMapA <*> materialiseFacePaints b paintMapB+            )++    return (materialisedPaintMap, makeShapeHistory . upcast $ builder)+ -- | Take the sum of two solids -- -- The region occupied by either one of them. union3D :: Solid -> Solid -> Solid-union3D = toBoolean Fuse.fuse-+union3D = toBoolean Fuse.fromShapes  toBooleans :: BOPAlgo.Operation.Operation -> [Solid] -> Solid toBooleans _ [] = emptySolid toBooleans _ [x] = x-toBooleans op (h:solids) = Solid . unsafeFromAcquire $ do-    firstPtr <- toAcquire . rawSolid $ h-    ptrs <- traverse (toAcquire . rawSolid) solids+toBooleans op solids@(h:t) = solidFromAcquireMappingPaintMap $ do+    firstPtr <- acquireSolid $ h+    ptrs <- traverse acquireSolid t     bop <- BOPAlgo.BOP.new     let builder = upcast bop     liftIO $ do@@ -136,8 +304,18 @@         traverse_ (BOPAlgo.BOP.addTool bop) ptrs         BOPAlgo.setRunParallel builder True         BOPAlgo.Builder.perform builder-    BOPAlgo.Builder.shape builder +    let matchesUniformPaint pa (UniformPaint pb) = pa == pb+        matchesUniformPaint _ _ = False++    combinedPaintMap <- +        case solidPaintMap h of+            UniformPaint p | all (matchesUniformPaint p . solidPaintMap) t -> +                pure $ UniformPaint p+            _ -> liftIO $ FacePaints <$> fromAcquirePaints (concat <$> traverse materialiseSolidFacePaints solids)+            +    return  (combinedPaintMap, bopBuilderHistory builder)+ -- | Take the sum of a list of solids  --  -- May be more performant than chaining multiple applications of `union3D`@@ -148,13 +326,13 @@ --  -- The region occupied by the first, but not the second. difference3D :: Solid -> Solid -> Solid-difference3D = toBoolean Cut.cut+difference3D = toBoolean Cut.fromShapes  -- | Take the intersection of two solids  -- -- The region occupied by both of them. intersection3D :: Solid -> Solid -> Solid-intersection3D = toBoolean Common.common+intersection3D = toBoolean Common.fromShapes   -- | Take the intersection of a list of solids 

@@ -19,7 +19,7 @@  import Linear (V3 (..)) import Waterfall.Internal.Path (Path, rawPath)-import Waterfall.Internal.Solid (Solid (..), solidFromAcquireWithCatch)+import Waterfall.Internal.Solid (Solid (..), solidFromAcquireWithCatch, emptyPaintMap) import Waterfall.Internal.ToOpenCascade (v3ToVertex) import Waterfall.Internal.Path.Common (rawPathWire) import qualified OpenCascade.BRepOffsetAPI.ThruSections as ThruSections@@ -36,10 +36,10 @@     -> [Path] -- ^ Series of cross-sections that the loft will pass through     -> Maybe (V3 Double) -- ^ Optional end point for the loft     -> Either WaterfallError Solid-tryPointedLoftWithPrecision precision start paths end = solidFromAcquireWithCatch $ do+tryPointedLoftWithPrecision precision start paths end = solidFromAcquireWithCatch emptyPaintMap $ do     thruSections <- ThruSections.new True False precision     forM_ start ((liftIO . ThruSections.addVertex thruSections) <=< v3ToVertex)-    forM_ paths (traverse (liftIO . ThruSections.addWire thruSections) . rawPathWire . rawPath)+    forM_ paths (traverse (liftIO . ThruSections.addWire thruSections) <=< rawPathWire . rawPath)     forM_ end ((liftIO . ThruSections.addVertex thruSections) <=< v3ToVertex)     MakeShape.shape (upcast thruSections) 

@@ -1,12 +1,35 @@-module Waterfall.Offset +{-# LANGUAGE TupleSections #-}+{-|+Module: Waterfall.Offset++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.+-}+module Waterfall.Offset ( offset , offsetWithTolerance+, offsetWithPaint+, offsetWithToleranceWithPaint -- * Functions that return Errors , tryOffset , tryOffsetWithTolerance-) where +, tryOffsetWithPaint+, tryOffsetWithToleranceWithPaint+) where -import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquireWithCatch, solidFromAcquireTWithCatch)+import Waterfall.Internal.Solid (Solid (..), acquireSolid, acquireFacePaints, fromAcquirePaints, PaintMap (..), makeShapeHistory, solidFromAcquireTWithPaintMapWithCatch) import qualified OpenCascade.BRepOffsetAPI.MakeOffsetShape as MakeOffsetShape import Control.Monad.IO.Class (liftIO) import OpenCascade.Inheritance (SubTypeOf(upcast), unsafeDowncast)@@ -18,12 +41,20 @@ import qualified OpenCascade.TopoDS.Shape as TopoDS.Shape import qualified OpenCascade.TopExp.Explorer as TopExp.Explorer import qualified OpenCascade.TopAbs.ShapeEnum as TopAbs.ShapeEnum-import Control.Monad (when)+import Control.Monad (when, filterM) import Foreign.Ptr (Ptr) import Data.Acquire (Acquire) import Waterfall.Internal.NearZero (nearZero) import Waterfall.Error (WaterfallError) import Data.Either (fromRight)+import Waterfall.Internal.Edges (allSubShapesWithCopy)+import qualified Waterfall.Internal.ShapeMap as ShapeMap+import qualified OpenCascade.TopAbs.ShapeEnum as ShapeEnum+import Data.Maybe (isJust)+import Waterfall.Internal.PaintHistory (remapWithBlendFunction)+import Data.List.NonEmpty (NonEmpty)+import Waterfall.Paint (Paint)+import qualified Data.List.NonEmpty as NE  combineShellsToSolid :: Ptr TopoDS.Shape -> Acquire (Ptr TopoDS.Shape) combineShellsToSolid s = do@@ -52,68 +83,108 @@                     (solid :) <$> go     go -offsetOneWithTolerance :: -    Double       -    -> Double   ++filterPaintMap :: Ptr TopoDS.Shape -> PaintMap -> Acquire PaintMap+filterPaintMap _ (UniformPaint paint) = pure (UniformPaint paint)+filterPaintMap s (FacePaints paints) = do+    faceSet <- liftIO . ShapeMap.fromList . fmap (,()) =<< allSubShapesWithCopy ShapeEnum.Face s+    fmap FacePaints . liftIO . fromAcquirePaints $+        ( filterM (liftIO . fmap isJust . ShapeMap.lookup faceSet . upcast . fst) +            =<< acquireFacePaints paints+        )++offsetOneWithTolerance ::+    Double+    -> Double+    -> (NonEmpty Paint -> Paint)+    -> PaintMap     -> Ptr TopoDS.Shape-    -> Acquire (Ptr TopoDS.Shape)-offsetOneWithTolerance tolerance value s = do+    -> Acquire (PaintMap, Ptr TopoDS.Shape)+offsetOneWithTolerance tolerance value paintFn paintMap s = do     builder <- MakeOffsetShape.new-    liftIO $ MakeOffsetShape.performByJoin builder s value tolerance Mode.Skin False False GeomAbs.JoinType.Arc False +    allEdges <- traverse (liftIO . unsafeDowncast) =<< allSubShapesWithCopy ShapeEnum.Edge s+    liftIO $ MakeOffsetShape.performByJoin builder s value tolerance Mode.Skin False False GeomAbs.JoinType.Arc False     shell <- MakeShape.shape (upcast builder)-    combineShellsToSolid shell+    newPaintMap <- remapWithBlendFunction paintFn s allEdges (makeShapeHistory $ upcast builder)+        =<< filterPaintMap s paintMap+    (newPaintMap,) <$> combineShellsToSolid shell --- | Version of `offsetWithTolerance` that returns an error on failure-tryOffsetWithTolerance :: -    Double       -    -> Double   -    -> Solid   ++-- | Version of `tryOffsetWithTolerance` that exposes how to assign `Paint` to the generated parts of the surface+tryOffsetWithToleranceWithPaint+    :: Double -- ^ Tolerance, this can be relatively small+    -> (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a generated surface to the `Paint` used for the surface+    -> Double -- ^ Amount to offset by, positive values expand, negative values contract+    -> Solid -- ^ The `Solid` to offset     -> Either WaterfallError Solid-tryOffsetWithTolerance tolerance value solid+tryOffsetWithToleranceWithPaint tolerance paintFn value solid     | nearZero value = Right solid-    | otherwise = -        fmap mconcat -        . solidFromAcquireTWithCatch -        $ traverse (offsetOneWithTolerance tolerance value) -        =<< getCompoundAsSolids +    | otherwise =+        fmap mconcat+        . solidFromAcquireTWithPaintMapWithCatch+        $ traverse (offsetOneWithTolerance tolerance value paintFn (solidPaintMap solid))+        =<< getCompoundAsSolids         =<< acquireSolid solid -offsetWithTolerance :: -    Double       -- ^ Tolerance, this can be relatively small-    -> Double    -- ^ Amount to offset by, positive values expand, negative values contract-    -> Solid        -- ^ the `Solid` to offset +-- | Version of `offsetWithTolerance` that returns an error on failure+tryOffsetWithTolerance+    :: Double -- ^ Tolerance, this can be relatively small+    -> Double -- ^ Amount to offset by, positive values expand, negative values contract+    -> Solid -- ^ The `Solid` to offset+    -> Either WaterfallError Solid+tryOffsetWithTolerance tolerance+    = tryOffsetWithToleranceWithPaint tolerance NE.head++-- | Version of `offset` that exposes the tolerance value used by the offset 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-offsetWithTolerance tolerance value solid = +offsetWithTolerance tolerance value solid =     fromRight mempty $ tryOffsetWithTolerance tolerance value solid +-- | Version of `offsetWithTolerance` that exposes how to assign `Paint` to the generated parts of the surface+offsetWithToleranceWithPaint+    :: Double -- ^ Tolerance, this can be relatively small+    -> (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a generated surface to the `Paint` used for the surface+    -> Double -- ^ Amount to offset by, positive values expand, negative values contract+    -> Solid -- ^ The `Solid` to offset+    -> Solid+offsetWithToleranceWithPaint tolerance paintFn value solid =+    fromRight mempty $ tryOffsetWithToleranceWithPaint tolerance paintFn value solid+ defaultTolerance :: Double defaultTolerance = 1e-6  -- | 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 +offset+    :: Double -- ^ Amount to offset by, positive values expand, negative values contract+    -> Solid -- ^ The `Solid` to offset     -> Solid offset = offsetWithTolerance defaultTolerance  +-- | Version of `offset` that exposes how to assign `Paint` to the generated parts of the surface+offsetWithPaint+    :: (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a generated surface to the `Paint` used for the surface+    -> Double -- ^ Amount to offset by, positive values expand, negative values contract+    -> Solid -- ^ The `Solid` to offset+    -> Solid+offsetWithPaint = offsetWithToleranceWithPaint defaultTolerance+ -- | Version of `offset` that returns an error on failure-tryOffset  :: -    Double    -- ^ Amount to offset by, positive values expand, negative values contract-    -> Solid        -- ^ the `Solid` to offset +tryOffset+    :: Double -- ^ Amount to offset by, positive values expand, negative values contract+    -> Solid -- ^ The `Solid` to offset     -> Either WaterfallError Solid tryOffset = tryOffsetWithTolerance defaultTolerance +-- | Version of `tryOffset` that exposes how to assign `Paint` to the generated parts of the surface+tryOffsetWithPaint+    :: (NonEmpty Paint -> Paint) -- ^ Maps the `Paint` on the neighbouring faces of a generated surface to the `Paint` used for the surface+    -> Double -- ^ Amount to offset by, positive values expand, negative values contract+    -> Solid -- ^ The `Solid` to offset+    -> Either WaterfallError Solid+tryOffsetWithPaint =+    tryOffsetWithToleranceWithPaint defaultTolerance

@@ -0,0 +1,208 @@+{-# LANGUAGE DerivingVia, DeriveGeneric #-}+{-# LANGUAGE InstanceSigs #-}+{-|+Module: Waterfall.Paint++`Paint` can be applied to change the appearance of the surface of a `Waterfall.Solids.Solid` (with `Waterfall.Solids.paintSolid`).++`Paint` values can be constructed from the @paintWith*@ functions and can be combined monoidally (with `<>`), e.g.++@+redShinyPaint =+    paintWithColour (Colour 1 0 0)+    <> paintWithRoughness 0.01+    <> paintWithMetallic 1+    <> paintWithDoubleSidedness SingleSided+@++Not all `Paint` properties are supported by every file format:++* glTF and OBJ use the full set+* STEP only uses the colour+* SVG uses colour and opacity+-}+module Waterfall.Paint +( Colour (..)+, Paint+, DoubleSidedness (..)+, defaultPaint+, paintIsDefined+-- * Constructors+, paintWithColour+, paintWithOpacity+, paintWithMetallic+, paintWithRoughness+, paintWithEmissiveColour+, paintWithName+, paintWithDoubleSidedness+-- * Optics+, paintColour+, paintOpacity+, paintMetallic+, paintRoughness+, paintEmissiveColour+, paintName+, paintDoubleSidedness+) where+import Data.Monoid (Last (..), Endo (..))+import GHC.Generics (Generically (..), Generic)+import Data.Maybe (catMaybes)+import Data.List (intersperse)+import Control.Lens (Lens', lens)+import Waterfall.Colour (Colour (..))+import Control.DeepSeq (NFData (rnf), rwhnf)++-- | Whether to display a surface as Double or Single Sided+--+-- In most formats and viewers this will be implemented using backface culling +data DoubleSidedness = SingleSided | DoubleSided +    deriving (Eq, Ord, Show) ++instance NFData DoubleSidedness where rnf = rwhnf++-- | Can be applied to change the appearance of the surface of a `Solid`+-- +-- `Paint` values can be constructed from the @paintWith*@ functions+-- and can be combined monoidally (with `<>`).+data Paint = Paint +    { _paintColour :: Last Colour+    , _paintOpacity :: Last Double+    , _paintMetallic :: Last Double+    , _paintRoughness :: Last Double+    , _paintEmissiveColour :: Last Colour+    , _paintName :: Last String+    , _paintDoubleSidedness :: Last DoubleSidedness+    } deriving (Eq, Ord, Generic)+    deriving +        ( Semigroup -- ^ `(<>)` takes the rightmost defined value of each property.+        , Monoid+        ) via (Generically Paint)++instance NFData Paint++instance Show Paint where+  showsPrec :: Int -> Paint -> ShowS+  showsPrec d p = +    let term name field = +            let fv v = +                    showString name+                     . showChar ' '+                     . showsPrec 11 v +            in fv <$> getLast (field p)+        terms = catMaybes +            [ term "paintWithColour" _paintColour+            , term "paintWithOpacity" _paintOpacity+            , term "paintWithMetallic" _paintMetallic+            , term "paintWithRoughness" _paintRoughness+            , term "paintWithEmissiveColour" _paintEmissiveColour+            , term "paintWithName" _paintName+            , term "paintWithDoubleSidedness" _paintDoubleSidedness+            ]+    in case terms of+        [] -> showString "mempty"+        _ -> showParen (d > 6) . appEndo+            . foldMap Endo+            . intersperse (showString " <> ") +            $ terms++-- | Fallback values used when a paint is unset+--+-- @+-- defaultPaint /= mempty+-- @+defaultPaint :: Paint+defaultPaint = paintWithColour (Colour 1 1 1)+    <> paintWithOpacity 1 +    <> paintWithDoubleSidedness DoubleSided+    <> paintWithMetallic 0+    <> paintWithRoughness 0.5++-- | Test whether a paint is storing any values+paintIsDefined :: Paint -> Bool+paintIsDefined = (/= mempty)++-- | The paint colour+paintColour :: Lens' Paint (Maybe Colour)+paintColour = +    lens+        (getLast . _paintColour) +        (\p c -> p { _paintColour = Last c })++-- | Create a paint with a given colour+paintWithColour :: Colour -> Paint+paintWithColour c = mempty { _paintColour = Last (Just c) }++-- | The paint opacity+paintOpacity :: Lens' Paint (Maybe Double)+paintOpacity = +    lens+        (getLast . _paintOpacity) +        (\p c -> p { _paintOpacity = Last c })++-- | Create a paint with a given opacity+--+-- Opacity is in the range [0, 1]+paintWithOpacity :: Double -> Paint+paintWithOpacity o = mempty { _paintOpacity = Last (Just o) }++-- | The paint "Metalness" value, in a [PBR](https://en.wikipedia.org/wiki/Physically_based_rendering) model.+paintMetallic :: Lens' Paint (Maybe Double)+paintMetallic = +    lens+        (getLast . _paintMetallic) +        (\p c -> p { _paintMetallic = Last c })++-- | Create a paint with a given "Metalness"+--+-- In the range [0, 1], 1 is fully metal.+paintWithMetallic :: Double -> Paint+paintWithMetallic m = mempty { _paintMetallic = Last (Just m) }+++-- | The paint "Roughness" value, in a [PBR](https://en.wikipedia.org/wiki/Physically_based_rendering) model.+paintRoughness :: Lens' Paint (Maybe Double)+paintRoughness = +    lens+        (getLast . _paintRoughness) +        (\p c -> p { _paintRoughness = Last c })++-- | Create a paint with a given roughness+-- +-- In the range [0, 1], 0 is perfectly smooth, 1 fully diffuse+paintWithRoughness :: Double -> Paint+paintWithRoughness r = mempty { _paintRoughness= Last (Just r) }++-- | The paint "Emissive" factor, in a [PBR](https://en.wikipedia.org/wiki/Physically_based_rendering) model.+--+-- EmissiveColour is written as linear RGB, rather than converted to sRGB.+paintEmissiveColour :: Lens' Paint (Maybe Colour)+paintEmissiveColour = +    lens+        (getLast . _paintEmissiveColour) +        (\p c -> p { _paintEmissiveColour = Last c })++-- | Create a paint with a given emissive factor+paintWithEmissiveColour :: Colour -> Paint+paintWithEmissiveColour c = mempty { _paintEmissiveColour = Last (Just c) }++-- | The paint name+paintName :: Lens' Paint (Maybe String)+paintName = +    lens+        (getLast . _paintName) +        (\p c -> p { _paintName = Last c })++-- | Create a paint with a given name+paintWithName :: String -> Paint+paintWithName n = mempty { _paintName = Last (Just n) }++-- | Whether to display a surface as Double or Single Sided+paintDoubleSidedness :: Lens' Paint (Maybe DoubleSidedness)+paintDoubleSidedness = +    lens+        (getLast . _paintDoubleSidedness) +        (\p c -> p { _paintDoubleSidedness = Last c })++-- | Create a paint with a given `DoubleSidedness`+paintWithDoubleSidedness :: DoubleSidedness -> Paint+paintWithDoubleSidedness ds = mempty { _paintDoubleSidedness = Last (Just ds) }

@@ -36,7 +36,7 @@ import Waterfall.Internal.Path.Common (RawPath (..)) import Waterfall.Internal.Path (Path (..)) import Waterfall.TwoD.Internal.Path2D (Path2D (..))-import Waterfall.Internal.Finalizers (unsafeFromAcquire, toAcquire, unsafeFromAcquireT)+import Waterfall.Internal.Finalizers (unsafeFromAcquire, unsafeFromAcquirePtr, acquireForeignPtr, unsafeFromAcquirePtrT) import Waterfall.Internal.FromOpenCascade (gpPntToV3) import Waterfall.Internal.Edges (wireEndpoints, reverseWire, splitWires, wireLength, truncateWire) import Waterfall.Internal.NearZero (nearZero)@@ -53,6 +53,7 @@ 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 qualified OpenCascade.BRepBuilderAPI.MakeShape as BRepBuilderAPI.MakeShape import Data.Proxy (Proxy (..)) import Linear (V3 (..), V2 (..), _xy, Epsilon) import qualified OpenCascade.GP.Pnt as GP.Pnt@@ -74,7 +75,7 @@     in GP.Pnt.new x y z   fromWire :: AnyPath point path => Acquire (Ptr TopoDS.Wire) -> path-fromWire = reconstructPath . ComplexRawPath . unsafeFromAcquire+fromWire = reconstructPath . ComplexRawPath . unsafeFromAcquirePtr  edgeToPath :: (AnyPath point path) => Acquire (Ptr TopoDS.Edge) -> path edgeToPath es = fromWire $ do@@ -206,10 +207,10 @@ 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)+            let (s, e) = unsafeFromAcquire $ do+                    wire <- acquireForeignPtr p+                    liftIO $ wireEndpoints wire+            in 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             @@ -222,8 +223,8 @@ splice path pnt =     case deconstructPath path of         ComplexRawPath unacquiredWire ->  -            let res = unsafeFromAcquire $ do-                    wire <- toAcquire unacquiredWire+            let res = unsafeFromAcquirePtrT $ do+                    wire <- acquireForeignPtr unacquiredWire                     (s, e) <- liftIO $ wireEndpoints wire                     let s' = v3ToPoint (Proxy :: Proxy path) s                         e' = v3ToPoint (Proxy :: Proxy path) e@@ -233,9 +234,12 @@                     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 +                    newWire <- +                        (liftIO . unsafeDowncast) +                            =<< BRepBuilderAPI.MakeShape.shape . upcast+                            =<< BRepBuilderAPI.Transform.fromShapeTrsfAndCopy (upcast wire) trsf True                     return (pnt + e' - s', newWire)-            in (fst res, fromWire (fmap snd . toAcquire $ res))+            in (fst res, fromWire (fmap snd . traverse acquireForeignPtr $ res))         _ -> (pnt, reconstructPath EmptyRawPath)  -- | Given a path, return a new path with the endpoints joined by a straight line.@@ -247,24 +251,25 @@             else p <> line e s         Nothing -> p +-- | Reverse the direction of a path reversePath :: (AnyPath point path) => path -> path reversePath p =      case deconstructPath p of-        ComplexRawPath r -> fromWire . reverseWire $ r+        ComplexRawPath r -> fromWire (reverseWire =<< acquireForeignPtr r)         _ -> p  -- | Break a path apart at any "non smooth" point splitPath :: (AnyPath point path) => path -> [path] splitPath p =      case deconstructPath p of -        ComplexRawPath r -> fmap (reconstructPath . ComplexRawPath) . unsafeFromAcquireT . splitWires $ r+        ComplexRawPath r -> fmap (reconstructPath . ComplexRawPath) . unsafeFromAcquirePtrT $ (splitWires =<< acquireForeignPtr r)         _ -> [p]  -- | Measure a path pathLength :: AnyPath point path => path -> Double pathLength p =     case deconstructPath p of-        ComplexRawPath r -> unsafeFromAcquire $ liftIO . wireLength =<< toAcquire r+        ComplexRawPath r -> unsafeFromAcquire $ liftIO . wireLength =<< acquireForeignPtr r         _ -> 0  -- | Truncate a path to a fraction of its total length.@@ -282,7 +287,7 @@     | otherwise =         case deconstructPath p of             ComplexRawPath r -> fromWire $ do-                wire <- toAcquire r+                wire <- acquireForeignPtr r                 totalLength <- liftIO $ wireLength wire                 let targetLength = fraction * totalLength                 truncateWire targetLength wire

@@ -3,9 +3,9 @@ , tryRevolution ) where -import Waterfall.Internal.Solid (Solid (..), solidFromAcquireWithCatch)+import Waterfall.Internal.Solid (Solid (..), solidFromAcquireWithCatch, emptyPaintMap) import Waterfall.TwoD.Internal.Path2D (Path2D (..))-import Waterfall.Internal.Finalizers (toAcquire)+import Waterfall.Internal.Finalizers (acquireForeignPtr) import qualified OpenCascade.BRepPrimAPI.MakeRevol as MakeRevol import qualified OpenCascade.BRepBuilderAPI.MakeSolid as MakeSolid import qualified OpenCascade.BRepBuilderAPI.MakeShape as MakeShape@@ -23,8 +23,8 @@ -- Revolution can fail, for example, if the `Path2D` crosses the axis of revolution. tryRevolution :: Path2D -> Either WaterfallError Solid tryRevolution (Path2D (ComplexRawPath theRawPath)) =-    fmap (rotate (unit _x) (pi/2)) . solidFromAcquireWithCatch $ do-        p <- toAcquire theRawPath+    fmap (rotate (unit _x) (pi/2)) . solidFromAcquireWithCatch emptyPaintMap $ do+        p <- acquireForeignPtr theRawPath         axis <- GP.oy -- revolve around the y axis         revol <- MakeRevol.fromShapeAndAx1 (upcast p) axis True         shell <- MakeShape.shape (upcast revol)

@@ -13,6 +13,8 @@ , octahedron , dodecahedron , icosahedron+, colourSolid+, paintSolid , prism , volume , centerOfMass@@ -20,8 +22,10 @@ ) where  -import Waterfall.Internal.Solid (Solid (..), solidFromAcquire, acquireSolid, emptySolid)-import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)+import Waterfall.Internal.Solid (Solid (..), PaintMap (..), solidFromAcquire, acquireSolid, emptySolid, emptyPaintMap)+import Waterfall.Paint (Paint, paintWithColour)+import Waterfall.Internal.Finalizers (NoPtr, acquireForeignPtr, unsafeFromAcquire)+import Control.DeepSeq (NFData) import Waterfall.TwoD.Internal.Shape (rawShape) import Waterfall.Internal.ToOpenCascade (v3ToVertex) import Waterfall.Internal.FromOpenCascade (gpPntToV3)@@ -29,6 +33,7 @@ import Waterfall.Transforms (translate, rotate) import Waterfall.Internal.NearZero (nearZero) import qualified Waterfall.TwoD.Shape as TwoD.Shape+import Waterfall.Colour (Colour) import qualified OpenCascade.BRepBuilderAPI.MakeShape as MakeShape import qualified OpenCascade.BRepBuilderAPI.MakeEdge as MakeEdge import qualified OpenCascade.BRepBuilderAPI.MakeWire as MakeWire@@ -61,7 +66,7 @@  -- | A cube with side lengths of 1, one vertex on the origin, another on \( (1, 1, 1) \) unitCube :: Solid-unitCube = solidFromAcquire $ do+unitCube = solidFromAcquire emptyPaintMap $ do     a <- GP.origin     b <- GP.Pnt.new 1 1 1     builder <- MakeBox.fromPnts a b@@ -69,7 +74,7 @@  -- | A cube with side lengths of 1, centered on the origin centeredCube :: Solid-centeredCube = solidFromAcquire $ do+centeredCube = solidFromAcquire emptyPaintMap $ 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@@ -79,7 +84,7 @@ box :: V3 Double -> Solid box v@(V3 x y z)      | any nearZero v = mempty-    | otherwise = solidFromAcquire $ do+    | otherwise = solidFromAcquire emptyPaintMap $ do         a <- GP.origin         b <- GP.Pnt.new x y z         builder <- MakeBox.fromPnts a b@@ -88,13 +93,13 @@      -- | A sphere with radius of 1, centered on the origin unitSphere :: Solid-unitSphere = solidFromAcquire $ Inheritance.upcast <$> MakeSphere.fromRadius 1+unitSphere = solidFromAcquire emptyPaintMap $ Inheritance.upcast <$> MakeSphere.fromRadius 1  -- | A cylinder with radius 1, length 1, -- one of its circular faces centered on the origin, -- the other centered on \( (0, 0, 1) \) unitCylinder :: Solid-unitCylinder = solidFromAcquire $ Inheritance.upcast <$> MakeCylinder.fromRadiusAndHeight 1 1+unitCylinder = solidFromAcquire emptyPaintMap $ Inheritance.upcast <$> MakeCylinder.fromRadiusAndHeight 1 1  -- | A cylinder with radius 1, length 1, -- centered on the origin@@ -112,7 +117,7 @@     -> Solid torus major minor      | major < minor = mempty  -    | otherwise = solidFromAcquire+    | otherwise = solidFromAcquire emptyPaintMap          $ MakeShape.shape           . Inheritance.upcast           =<< MakeTorus.fromRadii major minor@@ -121,7 +126,7 @@ -- With a point at the origin  -- and a circular face with Radius 1, centered on \( (0, 0, 1) \) unitCone :: Solid-unitCone = solidFromAcquire $ Inheritance.upcast <$> MakeCone.fromTwoRadiiAndHeight 0 1 1+unitCone = solidFromAcquire emptyPaintMap $ Inheritance.upcast <$> MakeCone.fromTwoRadiiAndHeight 0 1 1  -- | Extrude a 2D face into a prism with a given length \(len\). --@@ -130,8 +135,8 @@ prism :: Double -> TwoD.Shape.Shape -> Solid prism len face      | nearZero len = mempty-    | otherwise = solidFromAcquire $ do-        p <- toAcquire . rawShape $ face+    | otherwise = solidFromAcquire emptyPaintMap $ do+        p <- acquireForeignPtr . rawShape $ face         v <- GP.Vec.new 0 0 len         MakePrism.fromVec p v True True @@ -162,7 +167,7 @@         Nothing -> error "Failed to construct solid from faces"  solidFromVerts :: [[V3 Double]] -> Solid-solidFromVerts = solidFromAcquire . fmap Inheritance.upcast . (solidFromFaces <=< traverse faceFromVerts)+solidFromVerts = solidFromAcquire emptyPaintMap . fmap Inheritance.upcast . (solidFromFaces <=< traverse faceFromVerts)  -- | Regular Tetrahedron with unit side lengths -- @@ -249,7 +254,21 @@         , \x z -> [ pink x (-1), pink x 1, orange x 1 z, blue x z, orange x (-1) z]          ] <*> plusMinusOne <*> plusMinusOne -gPropQuery :: (Ptr GProps.GProps -> Acquire a) -> Solid -> a++-- | Apply a `Colour` to a `Solid`+--+-- Replaces any previously applied paint+colourSolid :: Colour -> Solid -> Solid+colourSolid colour = paintSolid (paintWithColour colour)++-- | Apply a `Paint` to a `Solid`+--+-- Replaces any previously applied paint+paintSolid :: Paint -> Solid -> Solid+paintSolid paint (Solid s _) = +    Solid s (UniformPaint paint )++gPropQuery :: (NoPtr a, NFData a) => (Ptr GProps.GProps -> Acquire a) -> Solid -> a gPropQuery f s = unsafeFromAcquire $ do     solid <- acquireSolid s     gProp <- GProps.new

@@ -3,11 +3,11 @@ , trySweep ) where -import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire, solidFromAcquireWithCatch)+import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire, solidFromAcquireWithCatch, emptyPaintMap) import Waterfall.Internal.Path (Path (..)) import Waterfall.Internal.Path.Common (RawPath (..)) import Waterfall.Internal.Edges (wireTangentStart, wireEndpoints)-import Waterfall.Internal.Finalizers (toAcquire)+import Waterfall.Internal.Finalizers (acquireForeignPtr) import Waterfall.Internal.NearZero (nearZero) import Waterfall.Transforms (rotate, translate) import Waterfall.TwoD.Internal.Shape (Shape (..))@@ -34,17 +34,17 @@                             then unit _x                              else z `cross` vn                     angle = acos (vn `dot` z)-                in acquireSolid . rotate axis angle . solidFromAcquire . pure $ face +                in acquireSolid . rotate axis angle . solidFromAcquire emptyPaintMap . pure $ face   positionFace :: V3 Double -> Ptr TopoDS.Shape -> Acquire (Ptr TopoDS.Shape)-positionFace p = acquireSolid . translate p . solidFromAcquire . pure+positionFace p = acquireSolid . translate p . solidFromAcquire emptyPaintMap . pure   -- | Version of `sweep` that returns an Error on Failure trySweep :: Path -> Shape -> Either WaterfallError Solid-trySweep (Path (ComplexRawPath theRawPath)) (Shape theRawShape) = solidFromAcquireWithCatch $ do-    path <- toAcquire theRawPath-    shape <- toAcquire theRawShape+trySweep (Path (ComplexRawPath theRawPath)) (Shape theRawShape) = solidFromAcquireWithCatch emptyPaintMap $ do+    path <- acquireForeignPtr theRawPath+    shape <- acquireForeignPtr theRawShape     tangent <- liftIO $ wireTangentStart path     (start,_)  <- liftIO $ wireEndpoints path     adjustedFace <- positionFace start =<< rotateFace tangent shape

@@ -17,8 +17,8 @@ , _rotated , _mirrored ) where-import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire)-import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire) +import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquireMappingPaintMap, makeShapeHistory)+import Waterfall.Internal.Finalizers (acquireForeignPtr, unsafeFromAcquirePtr)  import Waterfall.Internal.Path.Common (RawPath(..)) import Waterfall.Internal.NearZero (nearZero) import Linear.V3 (V3 (..))@@ -34,6 +34,7 @@ import qualified OpenCascade.GP.Vec as GP.Vec import qualified OpenCascade.BRepBuilderAPI.Transform  as BRepBuilderAPI.Transform import qualified OpenCascade.BRepBuilderAPI.GTransform  as BRepBuilderAPI.GTransform+import qualified OpenCascade.BRepBuilderAPI.MakeShape  as BRepBuilderAPI.MakeShape import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Data.Acquire@@ -60,34 +61,42 @@     mirror :: V3 Double -> a -> a  fromTrsfSolid :: Acquire (Ptr GP.Trsf) -> Solid -> Solid-fromTrsfSolid mkTrsf s = solidFromAcquire $ do +fromTrsfSolid mkTrsf s = solidFromAcquireMappingPaintMap $ do      solid <- acquireSolid s     trsf <- mkTrsf -    BRepBuilderAPI.Transform.transform solid trsf True -+    builder <- BRepBuilderAPI.Transform.fromShapeTrsfAndCopy solid trsf True +    return (solidPaintMap s, makeShapeHistory . upcast $ builder )+     fromGTrsfSolid :: Acquire (Ptr GP.GTrsf) -> Solid -> Solid-fromGTrsfSolid mkTrsf s = solidFromAcquire $ do +fromGTrsfSolid mkTrsf s = solidFromAcquireMappingPaintMap $ do      solid <- acquireSolid s     trsf <- mkTrsf -    BRepBuilderAPI.GTransform.gtransform solid trsf True +    builder <- BRepBuilderAPI.GTransform.fromShapeGTrsfAndCopy solid trsf True +    return (solidPaintMap s, makeShapeHistory . upcast $ builder )  transformPathSinglePointPaths :: (V3 Double -> V3 Double) -> Path -> Path transformPathSinglePointPaths f (Path (SinglePointRawPath v)) = Path . SinglePointRawPath . f $ v  transformPathSinglePointPaths _ p = p   fromTrsfPath :: (V3 Double -> V3 Double) -> Acquire (Ptr GP.Trsf) -> Path -> Path-fromTrsfPath _ mkTrsf (Path (ComplexRawPath p)) = Path . ComplexRawPath . unsafeFromAcquire $ do -    path <- toAcquire p+fromTrsfPath _ mkTrsf (Path (ComplexRawPath p)) = Path . ComplexRawPath . unsafeFromAcquirePtr $ do +    path <- acquireForeignPtr p     trsf <- mkTrsf -    (liftIO . unsafeDowncast) =<< BRepBuilderAPI.Transform.transform (upcast path) trsf True +    (liftIO . unsafeDowncast)+        =<< BRepBuilderAPI.MakeShape.shape+        =<< fmap upcast +            (BRepBuilderAPI.Transform.fromShapeTrsfAndCopy (upcast path) trsf True) fromTrsfPath f _ (Path (SinglePointRawPath v)) = Path . SinglePointRawPath . f $ v fromTrsfPath _ _ (Path EmptyRawPath) = Path EmptyRawPath  fromGTrsfPath :: (V3 Double -> V3 Double) -> Acquire (Ptr GP.GTrsf) -> Path -> Path-fromGTrsfPath _ mkTrsf (Path (ComplexRawPath p)) = Path . ComplexRawPath . unsafeFromAcquire $ do -    path <- toAcquire p+fromGTrsfPath _ mkTrsf (Path (ComplexRawPath p)) = Path . ComplexRawPath . unsafeFromAcquirePtr $ do +    path <- acquireForeignPtr p     trsf <- mkTrsf -    (liftIO . unsafeDowncast) =<< BRepBuilderAPI.GTransform.gtransform (upcast path) trsf True +    (liftIO . unsafeDowncast) +        =<< BRepBuilderAPI.MakeShape.shape+        =<< fmap upcast+            (BRepBuilderAPI.GTransform.fromShapeGTrsfAndCopy (upcast path) trsf True) fromGTrsfPath f _ (Path (SinglePointRawPath v)) = Path . SinglePointRawPath . f $ v fromGTrsfPath _ _ (Path EmptyRawPath) = Path EmptyRawPath 

@@ -5,6 +5,7 @@ ) where  import Waterfall.Internal.Path.Common (RawPath (..))+import Control.DeepSeq (NFData)  -- | A Path in 2D Space  --@@ -14,4 +15,5 @@ -- which does not lie on this plane (without using Internal functions). -- -- 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+newtype Path2D = Path2D { rawPath :: RawPath }+    deriving (Semigroup, Monoid, NFData) via RawPath

@@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE FlexibleContexts #-} module Waterfall.TwoD.Internal.Shape ( Shape (..) , acquireShape@@ -15,18 +16,22 @@ import Foreign.Ptr import Data.Acquire (Acquire) import Algebra.Lattice-import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)+import Waterfall.Internal.Finalizers (acquireForeignPtr, unsafeFromAcquirePtr) import qualified OpenCascade.BRepAlgoAPI.Fuse as Fuse import qualified OpenCascade.BRepAlgoAPI.Cut as Cut import qualified OpenCascade.BRepAlgoAPI.Common as Common import qualified OpenCascade.TopoDS.Shape as TopoDS.Shape+import OpenCascade.BRepBuilderAPI (MakeShape) import qualified OpenCascade.BRepBuilderAPI.MakeFace as MakeFace+import qualified OpenCascade.BRepBuilderAPI.MakeShape as MakeShape import qualified OpenCascade.BOPAlgo.Operation as BOPAlgo.Operation import qualified OpenCascade.BOPAlgo.BOP as BOPAlgo.BOP import qualified OpenCascade.BOPAlgo.Builder as BOPAlgo.Builder-import OpenCascade.Inheritance (upcast)+import OpenCascade.Inheritance (SubTypeOf, upcast) import Control.Monad.IO.Class (liftIO) import Data.Foldable (traverse_)+import Foreign.ForeignPtr (ForeignPtr)+import Control.DeepSeq (NFData (rnf), rwhnf)  -- | A Region in 2D Space  -- @@ -39,41 +44,44 @@ -- 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 { rawShape :: Ptr TopoDS.Shape }+newtype Shape = Shape { rawShape :: ForeignPtr TopoDS.Shape } +instance NFData Shape where+    rnf = rwhnf . rawShape+ acquireShape :: Shape -> Acquire (Ptr TopoDS.Shape)-acquireShape (Shape ptr) = toAcquire ptr+acquireShape (Shape ptr) = acquireForeignPtr ptr  shapeFromAcquire :: Acquire (Ptr TopoDS.Shape) -> Shape-shapeFromAcquire = Shape . unsafeFromAcquire+shapeFromAcquire = Shape . unsafeFromAcquirePtr -toBoolean2D :: (Ptr TopoDS.Shape.Shape -> Ptr TopoDS.Shape.Shape -> Acquire (Ptr TopoDS.Shape.Shape)) -> Shape -> Shape -> Shape-toBoolean2D f (Shape ptrA) (Shape ptrB) = Shape . unsafeFromAcquire $ do-    a <- toAcquire ptrA-    b <- toAcquire ptrB-    f a b+toBoolean2D :: (SubTypeOf MakeShape a) => (Ptr TopoDS.Shape.Shape -> Ptr TopoDS.Shape.Shape -> Acquire (Ptr a)) -> Shape -> Shape -> Shape+toBoolean2D f (Shape ptrA) (Shape ptrB) = Shape . unsafeFromAcquirePtr $ do+    a <- acquireForeignPtr ptrA+    b <- acquireForeignPtr ptrB+    MakeShape.shape =<< fmap upcast (f a b)  -- | Take the union of two 2D shapes. -- The region occupied by either one of them union2D :: Shape -> Shape -> Shape-union2D = toBoolean2D Fuse.fuse+union2D = toBoolean2D Fuse.fromShapes  -- | Take the difference of two 2D shapes. -- The region occupied by the first, but not the second difference2D :: Shape -> Shape -> Shape-difference2D = toBoolean2D Cut.cut+difference2D = toBoolean2D Cut.fromShapes  -- | Take the intersection of two 2D shapes. -- The region occupied by both of them intersection2D :: Shape -> Shape -> Shape-intersection2D = toBoolean2D Common.common+intersection2D = toBoolean2D Common.fromShapes  toBooleans2D :: BOPAlgo.Operation.Operation -> [Shape] -> Shape toBooleans2D _ [] = emptyShape toBooleans2D _ [x] = x-toBooleans2D op (h:shapes) = Shape . unsafeFromAcquire $ do-    firstPtr <- toAcquire . rawShape $ h-    ptrs <- traverse (toAcquire . rawShape) shapes+toBooleans2D op (h:shapes) = Shape . unsafeFromAcquirePtr $ do+    firstPtr <- acquireForeignPtr . rawShape $ h+    ptrs <- traverse (acquireForeignPtr . rawShape) shapes     bop <- BOPAlgo.BOP.new     let builder = upcast bop     liftIO $ do@@ -96,7 +104,7 @@  -- | An empty 2D shape emptyShape :: Shape-emptyShape = Shape . unsafeFromAcquire $ +emptyShape = Shape . unsafeFromAcquirePtr $      upcast <$> (MakeFace.face =<< MakeFace.new)  -- defining these boolean operators here, rather than in Waterfall.TwoD.Booleans 

@@ -38,8 +38,13 @@ import Control.Lens ((^.)) import Linear ((^*), _xy, distance, normalize, unangle) import Waterfall.Path.Common+import Control.DeepSeq (NFData (rnf), rwhnf) +-- | The direction of a 2D rotation data Sense = Clockwise | Counterclockwise deriving (Eq, Show)++instance NFData Sense where+    rnf = rwhnf  -- | Section of a circle, with a given radius, that lies between two points. --

@@ -18,7 +18,7 @@ import Waterfall.TwoD.Internal.Shape (Shape (..), union2D, difference2D, intersection2D, unions2D, intersections2D, emptyShape) import Waterfall.TwoD.Internal.Path2D (Path2D (..)) import Waterfall.TwoD.Transforms (translate2D, rotate2D)-import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire, unsafeFromAcquireT)+import Waterfall.Internal.Finalizers (acquireForeignPtr, unsafeFromAcquirePtr, unsafeFromAcquirePtrT) import Waterfall.Internal.Edges (allWires) import qualified OpenCascade.BRepBuilderAPI.MakeFace as MakeFace import OpenCascade.Inheritance (upcast)@@ -28,10 +28,10 @@  -- | Construct a 2D Shape from a closed path  makeShape :: Path2D -> Shape-makeShape (Path2D (ComplexRawPath r)) = Shape . unsafeFromAcquire  $ do-    p <- toAcquire r+makeShape (Path2D (ComplexRawPath r)) = Shape . unsafeFromAcquirePtr  $ do+    p <- acquireForeignPtr r     upcast <$> (MakeFace.face =<< MakeFace.fromWire p False)-makeShape _ = Shape . unsafeFromAcquire $+makeShape _ = Shape . unsafeFromAcquirePtr $     upcast <$> (MakeFace.face =<< MakeFace.new)  -- | Get the paths back from a 2D shape@@ -45,8 +45,8 @@ -- Although this can only hold when the shape has one boundary path,  -- and is not guaranteed shapePaths :: Shape -> [Path2D] -shapePaths (Shape r) = fmap (Path2D . ComplexRawPath) . unsafeFromAcquireT $ do-    s <- toAcquire r +shapePaths (Shape r) = fmap (Path2D . ComplexRawPath) . unsafeFromAcquirePtrT $ do+    s <- acquireForeignPtr r      allWires s   -- | Circle with radius 1, centered on the origin

@@ -7,41 +7,46 @@ ) where  import qualified Waterfall.TwoD.Internal.Shape as Shape-import Waterfall.Internal.Finalizers (toAcquire, fromAcquire, unsafeFromAcquire)+import Waterfall.Internal.Finalizers (acquireForeignPtr, fromAcquirePtr, unsafeFromAcquirePtr) 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 import qualified OpenCascade.Graphic3D.VerticalTextAlignment as VTA import qualified OpenCascade.Graphic3D.HorizontalTextAlignment as HTA-import Foreign.Ptr +import Foreign.ForeignPtr (ForeignPtr) import Control.Monad (unless) import OpenCascade.Font.FontAspect (FontAspect (..))+import Control.Monad.IO.Class (liftIO) import Control.Exception (throwIO)+import Control.DeepSeq (NFData (rnf), rwhnf) -newtype Font = Font { rawFont :: Ptr BRepFont.BRepFont }+newtype Font = Font { rawFont :: ForeignPtr BRepFont.BRepFont } +instance NFData Font where+    rnf (Font ptr) = rwhnf ptr+ -- | Create a font from a filepath and a font size  fontFromPath :: FilePath -> Double -> IO Font -fontFromPath fontpath size = do-    bRepFont <- fromAcquire $ BRepFont.new-    fontOk <- BRepFont.initFromPathAndSize bRepFont fontpath size-    unless (fontOk) $ throwIO (WaterfallIOException FileError fontpath)-    return $ Font bRepFont+fontFromPath fontpath size = fmap Font . fromAcquirePtr $ do+    bRepFont <- BRepFont.new+    fontOk <- liftIO $ BRepFont.initFromPathAndSize bRepFont fontpath size+    unless fontOk $ liftIO (throwIO (WaterfallIOException FileError fontpath))+    return bRepFont  -- | Create a font from a system font name, aspect, and 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) $ throwIO $ WaterfallIOException FileError (name <> "::" <> show aspect)-    return $ Font bRepFont+fontFromSystem name aspect size = fmap Font . fromAcquirePtr $ do+    bRepFont <- BRepFont.new+    fontOk <- liftIO $ BRepFont.initFromNameAspectAndSize bRepFont name aspect size+    unless fontOk . liftIO $ throwIO $ WaterfallIOException FileError (name <> "::" <> show aspect)+    return bRepFont  -- | Render text, using a given font text :: Font -> String -> Shape.Shape -text font content = Shape.Shape . unsafeFromAcquire $ do+text font content = Shape.Shape . unsafeFromAcquirePtr $ do     axis <- GP.Ax3.new-    bRepFont <- toAcquire . rawFont $ font+    bRepFont <- acquireForeignPtr . rawFont $ font     builder <- BRepTextBuilder.new     BRepTextBuilder.perform builder bRepFont content axis HTA.Center VTA.Center 

@@ -19,7 +19,7 @@ ) where  import Waterfall.TwoD.Internal.Path2D (Path2D (..))-import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire)+import Waterfall.Internal.Finalizers (acquireForeignPtr, unsafeFromAcquirePtr) import Waterfall.Internal.NearZero (nearZero) import Linear ((*^), normalize, dot, V3 (..), V2 (..), (!*), _xy, _z, unit, M23) import qualified OpenCascade.GP.Trsf as GP.Trsf@@ -29,6 +29,7 @@ import qualified OpenCascade.GP.Ax2 as GP.Ax2 import qualified OpenCascade.GP.Dir as GP.Dir import qualified OpenCascade.GP.Vec as GP.Vec+import qualified OpenCascade.BRepBuilderAPI.MakeShape  as BRepBuilderAPI.MakeShape import qualified OpenCascade.BRepBuilderAPI.Transform  as BRepBuilderAPI.Transform import qualified OpenCascade.BRepBuilderAPI.GTransform  as BRepBuilderAPI.GTransform import OpenCascade.Inheritance (upcast, unsafeDowncast)@@ -38,9 +39,7 @@ import Waterfall.TwoD.Internal.Shape (Shape(..)) import Data.Function ((&)) import Control.Lens ((.~), (%~), Iso', iso)-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@@ -61,51 +60,48 @@     mirror2D :: V2 Double -> a -> a  fromTrsfPath :: (V2 Double -> V2 Double) -> Acquire (Ptr GP.Trsf) -> Path2D -> Path2D-fromTrsfPath _ mkTrsf (Path2D (ComplexRawPath p)) = Path2D . ComplexRawPath . unsafeFromAcquire $ do -    path <- toAcquire p+fromTrsfPath _ mkTrsf (Path2D (ComplexRawPath p)) = Path2D . ComplexRawPath . unsafeFromAcquirePtr $ do +    path <- acquireForeignPtr p     trsf <- mkTrsf -    (liftIO . unsafeDowncast) =<< BRepBuilderAPI.Transform.transform (upcast path) trsf True +    (liftIO . unsafeDowncast) +        =<< BRepBuilderAPI.MakeShape.shape+        =<< fmap upcast+            (BRepBuilderAPI.Transform.fromShapeTrsfAndCopy (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+fromTrsfShape mkTrsf (Shape theRawShape) = Shape . unsafeFromAcquirePtr $ do +    shape <- acquireForeignPtr theRawShape     trsf <- mkTrsf -    BRepBuilderAPI.Transform.transform shape trsf True +    builder <- BRepBuilderAPI.Transform.fromShapeTrsfAndCopy shape trsf True +    BRepBuilderAPI.MakeShape.shape (upcast builder)      fromGTrsfPath :: (V2 Double -> V2 Double) -> Acquire (Maybe (Ptr GP.GTrsf)) -> Path2D -> Path2D-fromGTrsfPath _ mkTrsf (Path2D (ComplexRawPath p)) = Path2D . ComplexRawPath . unsafeFromAcquire  $ do -    path <- toAcquire p+fromGTrsfPath _ mkTrsf (Path2D (ComplexRawPath p)) = Path2D . ComplexRawPath . unsafeFromAcquirePtr  $ do +    path <- acquireForeignPtr p     trsfMay <- mkTrsf      case trsfMay of-        Just trsf -> (liftIO . unsafeDowncast) =<< BRepBuilderAPI.GTransform.gtransform (upcast path) trsf True +        Just trsf -> +            (liftIO . unsafeDowncast) +                =<< BRepBuilderAPI.MakeShape.shape+                =<< fmap upcast+                    (BRepBuilderAPI.GTransform.fromShapeGTrsfAndCopy (upcast path) trsf True)         Nothing -> pure path fromGTrsfPath f _ (Path2D (SinglePointRawPath v)) = Path2D . SinglePointRawPath $ (v & _xy %~ f) fromGTrsfPath _ _ (Path2D EmptyRawPath) = Path2D EmptyRawPath  fromGTrsfShape :: Acquire (Maybe (Ptr GP.GTrsf)) -> Shape -> Shape-fromGTrsfShape mkTrsf (Shape theRawShape) = Shape . unsafeFromAcquire $ do -    shape <- toAcquire theRawShape +fromGTrsfShape mkTrsf (Shape theRawShape) = Shape . unsafeFromAcquirePtr $ do +    shape <- acquireForeignPtr theRawShape      trsfMay <- mkTrsf      case trsfMay of-        Just trsf -> BRepBuilderAPI.GTransform.gtransform shape trsf True +        Just trsf -> +            BRepBuilderAPI.MakeShape.shape +                =<< fmap upcast+                    (BRepBuilderAPI.GTransform.fromShapeGTrsfAndCopy 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 -    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@@ -203,25 +199,6 @@      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

@@ -1,11 +1,11 @@-cabal-version: 1.12+cabal-version: 1.18  -- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack  name:           waterfall-cad-version:        0.6.3.2+version:        0.7.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@@ -21,6 +21,23 @@     LICENSE     README.md     CHANGELOG.md+extra-doc-files:+    doc-images/aqua.svg+    doc-images/black.svg+    doc-images/blue.svg+    doc-images/fuchsia.svg+    doc-images/green.svg+    doc-images/grey.svg+    doc-images/lime.svg+    doc-images/maroon.svg+    doc-images/navy.svg+    doc-images/olive.svg+    doc-images/purple.svg+    doc-images/red.svg+    doc-images/silver.svg+    doc-images/teal.svg+    doc-images/white.svg+    doc-images/yellow.svg  source-repository head   type: git@@ -33,6 +50,7 @@       Waterfall.Booleans.Operators       Waterfall.BoundingBox.AxisAligned       Waterfall.BoundingBox.Oriented+      Waterfall.Colour       Waterfall.Diagram       Waterfall.Error       Waterfall.Fillet@@ -41,14 +59,17 @@       Waterfall.Internal.Finalizers       Waterfall.Internal.FromOpenCascade       Waterfall.Internal.NearZero+      Waterfall.Internal.PaintHistory       Waterfall.Internal.Path       Waterfall.Internal.Path.Common       Waterfall.Internal.Remesh+      Waterfall.Internal.ShapeMap       Waterfall.Internal.Solid       Waterfall.Internal.ToOpenCascade       Waterfall.IO       Waterfall.Loft       Waterfall.Offset+      Waterfall.Paint       Waterfall.Path       Waterfall.Path.Common       Waterfall.Revolution@@ -68,12 +89,14 @@       src   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+      base >=4.17 && <5+    , bifunctors ==5.*+    , containers >=0.6 && <1+    , deepseq >=1.4 && <2     , filepath >=1.4 && <1.6     , lattices >=2.0 && <3     , lens ==5.*     , linear >=1.21 && <2-    , opencascade-hs >=0.6.3.2 && <0.7-    , primitive >=0.7 && <0.10+    , opencascade-hs >=0.7.0.0 && <0.8     , resourcet >=1.2 && <1.4   default-language: Haskell2010