diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,8 +6,17 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). - ## Unreleased + +## 0.6.0.1 + +### Added + +- Added `whenNearlyEqual` to `Waterfall.Fillet` to make writing conditional Fillets easier + +### Fixed + +- Workaround for an issue where calling `scale` with a uniform scale vector produced invalid geometry ## 0.6.0.0 diff --git a/src/Waterfall/Fillet.hs b/src/Waterfall/Fillet.hs --- a/src/Waterfall/Fillet.hs +++ b/src/Waterfall/Fillet.hs @@ -1,10 +1,21 @@ +{-# LANGUAGE RankNTypes #-} module Waterfall.Fillet -( roundFillet +( + -- * 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 , roundConditionalFillet , roundIndexedConditionalFillet +-- * Chamfers +-- | Adds flat faces at a constant angle to the two faces either side of an edge. , chamfer , conditionalChamfer , indexedConditionalChamfer +-- * Utility Methods +, whenNearlyEqual ) where import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire) @@ -21,7 +32,8 @@ import Control.Monad.IO.Class (liftIO) import OpenCascade.Inheritance (upcast, unsafeDowncast) import Linear.V3 (V3 (..)) - +import Linear.Epsilon +import Control.Lens (Lens', (^.)) 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 @@ -104,3 +116,18 @@ chamfer :: Double -> Solid -> Solid chamfer d = conditionalChamfer (const . pure $ d) +-- | Returns a value when the target of a lens on a two points are close to one another. +-- +-- This can be used in combination with `roundConditionalFillet`/`conditionalChamfer`. +-- +-- Selecting only horizontal edges: +-- +-- > roundConditionalFillet (whenNearlyEqual _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 diff --git a/src/Waterfall/Transforms.hs b/src/Waterfall/Transforms.hs --- a/src/Waterfall/Transforms.hs +++ b/src/Waterfall/Transforms.hs @@ -55,13 +55,11 @@ trsf <- mkTrsf BRepBuilderAPI.Transform.transform solid trsf True -fromGTrsfSolid :: Acquire (Maybe (Ptr GP.GTrsf)) -> Solid -> Solid +fromGTrsfSolid :: Acquire (Ptr GP.GTrsf) -> Solid -> Solid fromGTrsfSolid mkTrsf s = solidFromAcquire $ do solid <- acquireSolid s - trsfMay <- mkTrsf - case trsfMay of - Just trsf -> BRepBuilderAPI.GTransform.gtransform solid trsf True - Nothing -> pure solid + trsf <- mkTrsf + BRepBuilderAPI.GTransform.gtransform solid trsf True fromTrsfPath :: (V3 Double -> V3 Double) -> Acquire (Ptr GP.Trsf) -> Path -> Path fromTrsfPath _ mkTrsf (Path (ComplexRawPath p)) = Path . ComplexRawPath . unsafeFromAcquire $ do @@ -71,29 +69,29 @@ fromTrsfPath f _ (Path (SinglePointRawPath v)) = Path . SinglePointRawPath . f $ v fromTrsfPath _ _ (Path EmptyRawPath) = Path EmptyRawPath -fromGTrsfPath :: (V3 Double -> V3 Double) -> Acquire (Maybe (Ptr GP.GTrsf)) -> Path -> Path +fromGTrsfPath :: (V3 Double -> V3 Double) -> Acquire (Ptr GP.GTrsf) -> Path -> Path fromGTrsfPath _ mkTrsf (Path (ComplexRawPath p)) = Path . ComplexRawPath . unsafeFromAcquire $ do path <- toAcquire p - trsfMay <- mkTrsf - case trsfMay of - Just trsf -> (liftIO . unsafeDowncast) =<< BRepBuilderAPI.GTransform.gtransform (upcast path) trsf True - Nothing -> pure path + trsf <- mkTrsf + (liftIO . unsafeDowncast) =<< BRepBuilderAPI.GTransform.gtransform (upcast path) trsf True fromGTrsfPath f _ (Path (SinglePointRawPath v)) = Path . SinglePointRawPath . f $ v fromGTrsfPath _ _ (Path EmptyRawPath) = Path EmptyRawPath - -scaleTrsf :: V3 Double -> Acquire (Maybe (Ptr GP.GTrsf)) +scaleTrsf :: V3 Double -> Maybe (Either (Acquire (Ptr GP.Trsf)) (Acquire (Ptr GP.GTrsf))) scaleTrsf v@(V3 x y z ) = if v == V3 1 1 1 - then pure Nothing - else do - trsf <- GP.GTrsf.new - liftIO $ do - GP.GTrsf.setValue trsf 1 1 x - GP.GTrsf.setValue trsf 2 2 y - GP.GTrsf.setValue trsf 3 3 z - GP.GTrsf.setForm trsf - return . Just $ trsf + then Nothing + else + if x == y && y == z + then Just . Left $ uScaleTrsf x + else Just . Right $ do + trsf <- GP.GTrsf.new + liftIO $ do + GP.GTrsf.setValue trsf 1 1 x + GP.GTrsf.setValue trsf 2 2 y + GP.GTrsf.setValue trsf 3 3 z + GP.GTrsf.setForm trsf + return trsf uScaleTrsf :: Double -> Acquire (Ptr GP.Trsf) uScaleTrsf factor = do @@ -128,9 +126,10 @@ GP.Trsf.setMirrorAboutAx2 trsf axis return trsf -matrixGTrsf :: M34 Double -> Acquire (Maybe (Ptr GP.GTrsf)) -matrixGTrsf (V3 (V4 1 0 0 0) (V4 0 1 0 0) (V4 0 0 1 0)) = pure Nothing -matrixGTrsf (V3 (V4 v11 v12 v13 v14) (V4 v21 v22 v23 v24) (V4 v31 v32 v33 v34)) = do +matrixGTrsf :: M34 Double -> Maybe (Either (Acquire (Ptr GP.Trsf)) (Acquire (Ptr GP.GTrsf))) +matrixGTrsf (V3 (V4 1 0 0 0) (V4 0 1 0 0) (V4 0 0 1 0)) = Nothing +matrixGTrsf (V3 (V4 x 0 0 0) (V4 0 y 0 0) (V4 0 0 z 0)) | x == y && y == z = Just . Left . uScaleTrsf $ x +matrixGTrsf (V3 (V4 v11 v12 v13 v14) (V4 v21 v22 v23 v24) (V4 v31 v32 v33 v34)) = Just . Right $ do trsf <- GP.GTrsf.new liftIO $ do GP.GTrsf.setValue trsf 1 1 v11 @@ -146,14 +145,14 @@ GP.GTrsf.setValue trsf 3 3 v33 GP.GTrsf.setValue trsf 3 4 v34 GP.GTrsf.setForm trsf - return . pure $ trsf + return trsf instance Transformable Solid where matTransform :: M34 Double -> Solid -> Solid - matTransform = fromGTrsfSolid . matrixGTrsf + matTransform = maybe id (either fromTrsfSolid fromGTrsfSolid) . matrixGTrsf scale :: V3 Double -> Solid -> Solid - scale = fromGTrsfSolid . scaleTrsf + scale = maybe id (either fromTrsfSolid fromGTrsfSolid) . scaleTrsf uScale :: Double -> Solid -> Solid uScale = fromTrsfSolid . uScaleTrsf @@ -169,10 +168,14 @@ instance Transformable Path where matTransform :: M34 Double -> Path -> Path - matTransform m = fromGTrsfPath (matTransform m) (matrixGTrsf m) + matTransform m = + let transformPnt = matTransform m + in maybe id (either (fromTrsfPath transformPnt) (fromGTrsfPath transformPnt)) $ matrixGTrsf m scale :: V3 Double -> Path -> Path - scale s = fromGTrsfPath (scale s) (scaleTrsf s) + scale s = + let transformPnt = scale s + in maybe id (either (fromTrsfPath transformPnt) (fromGTrsfPath transformPnt)) $ scaleTrsf s uScale :: Double -> Path -> Path uScale s = fromTrsfPath (uScale s) (uScaleTrsf s) diff --git a/src/Waterfall/TwoD/Shape.hs b/src/Waterfall/TwoD/Shape.hs --- a/src/Waterfall/TwoD/Shape.hs +++ b/src/Waterfall/TwoD/Shape.hs @@ -71,14 +71,16 @@ -- -- Ill-defined when n <= 2 unitPolygon :: Integer -> Shape -unitPolygon n = - let n' = fromIntegral n - points = [ - rotate2D (2 * pi * fromIntegral i / n') (unit _x) - | i <- [0..n] - ] - paths = mconcat [ - line a b - | (a, b) <- zip points (tail points) - ] +unitPolygon n + | n <= 2 = error "Polygon with <= 2 points is ill defined" + | otherwise = + let n' = fromIntegral n + points = [ + rotate2D (2 * pi * fromIntegral i / n') (unit _x) + | i <- [0..n] + ] + paths = mconcat [ + line a b + | (a, b) <- zip points (drop 1 points) + ] in makeShape paths diff --git a/waterfall-cad.cabal b/waterfall-cad.cabal --- a/waterfall-cad.cabal +++ b/waterfall-cad.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: waterfall-cad -version: 0.6.0.0 +version: 0.6.0.1 synopsis: Declarative CAD/Solid Modeling Library description: Please see the README on GitHub at category: Graphics @@ -71,7 +71,7 @@ , lattices >=2.0 && <3 , lens ==5.* , linear >=1.21 && <2 - , opencascade-hs >=0.6.0.0 && <0.7 + , opencascade-hs >=0.6.0.1 && <0.7 , primitive >=0.7 && <0.10 , resourcet >=1.2 && <1.4 default-language: Haskell2010