Merge pull request #468 from Haskell-Things/lepsa/improving-shell

merged version of lepsa:improving-shell

CHANGELOG.md

@@ -1,6 +1,7 @@
 # Version [next](https://github.com/Haskell-Things/ImplicitCAD/compare/v0.4.1.0...master) (202Y-MM-DD)
 
-*
+* Other changes
+  * Fixing `shell` so that it doesn't increase the outside dimentions of objects.
 
 # Version [0.4.1.0](https://github.com/Haskell-Things/ImplicitCAD/compare/v0.4.0.0...v0.4.1.0) (2023-12-18)
 

Graphics/Implicit/ObjectUtil/GetBoxShared.hs

@@ -10,7 +10,7 @@
 
 module Graphics.Implicit.ObjectUtil.GetBoxShared (VectorStuff(uniformV, elements, corners), intersectBoxes, emptyBox, pointsBox, unionBoxes, outsetBox, getBoxShared) where
 
-import Prelude (Num, (-), (+), pure, (==), max, min, foldr, (/), ($), fmap, (.), not, filter, foldMap, Fractional, Bool, Eq)
+import Prelude (Num, (-), (+), pure, (==), max, min, foldr, ($), fmap, (.), not, filter, foldMap, Fractional, Bool, Eq)
 import {-# SOURCE #-} Graphics.Implicit.Primitives
     ( Object(getBox) )
 import Graphics.Implicit.Definitions
@@ -156,8 +156,8 @@ getBoxShared (Scale s symbObj) =
 getBoxShared (Mirror v symbObj) =
   pointsBox $ fmap (reflect v) $ corners $ getBox symbObj
 -- Boundary mods
-getBoxShared (Shell w symbObj) =
-    outsetBox (w/2) $ getBox symbObj
+-- Shell shouldn't be changing bounding boxes
+getBoxShared (Shell _ symbObj) = getBox symbObj
 getBoxShared (Outset d symbObj) =
     outsetBox d $ getBox symbObj
 -- Misc

Graphics/Implicit/ObjectUtil/GetImplicitShared.hs

@@ -23,6 +23,7 @@ import Graphics.Implicit.MathUtil (infty, rmax, rmaximum, rminimum, reflect)
 import Graphics.Implicit.ObjectUtil.GetBoxShared (VectorStuff(elements, uniformV))
 
 import Linear (Metric(dot))
+import {-# SOURCE #-} Graphics.Implicit.Primitives (outset)
 
 ------------------------------------------------------------------------------
 -- | Normalize a dimensionality-polymorphic vector.
@@ -76,8 +77,10 @@ getImplicitShared ctx (Scale s symbObj) = \p ->
 getImplicitShared ctx (Mirror v symbObj) =
     getImplicit' ctx symbObj . reflect v
 -- Boundary mods
-getImplicitShared ctx (Shell w symbObj) = \p ->
-  abs (getImplicit' ctx symbObj p) - w/2
+getImplicitShared ctx (Shell w symbObj) =
+  -- Get the difference of the original object, and the same
+  -- object with its boundaries moved towards the center.
+  getImplicitShared ctx (DifferenceR 0 symbObj [outset (-w) symbObj])
 getImplicitShared ctx (Outset d symbObj) = \p ->
   getImplicit' ctx symbObj p - d
 -- Misc

Graphics/Implicit/Primitives.hs-boot

@@ -7,7 +7,7 @@
 -- due to GHC 8.7.10 (and lesser) warning about Space
 {-# OPTIONS_GHC -fno-warn-missing-methods #-}
 
-module Graphics.Implicit.Primitives (Object(getBox, getImplicit', Space, _Shared), getImplicit, emptySpace, fullSpace) where
+module Graphics.Implicit.Primitives (Object(getBox, getImplicit', Space, _Shared), getImplicit, emptySpace, fullSpace,outset) where
 
 import Graphics.Implicit.Definitions (ObjectContext, SymbolicObj2, SymbolicObj3, SharedObj, ℝ)
 import Control.Lens (Prism')
@@ -38,3 +38,4 @@ instance Object SymbolicObj2 V2 ℝ
 instance Object SymbolicObj3 V3 ℝ
 
 emptySpace, fullSpace :: Object obj f a => obj
+outset :: Object obj f a => ℝ -> obj -> obj

tests/GoldenSpec/Spec.hs

@@ -1,6 +1,7 @@
 {- ORMOLU_DISABLE -}
 {-# OPTIONS_GHC -fno-warn-missing-import-lists #-}
 {-# OPTIONS_GHC -fno-warn-type-defaults        #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module GoldenSpec.Spec (spec) where
 
@@ -171,6 +172,7 @@ spec = describe "golden tests" $ do
       , ellipsoid 10 15 20
       , translate (V3 0 0 25) $ cone 20 20
       ]
+
   golden "closing-paths-1" 0.5 $
     extrudeM
       (Left 0)
@@ -218,3 +220,27 @@ spec = describe "golden tests" $ do
   describe "2d" $ do
     goldenFormat2 PNG "troublesome-polygon" 1 funPoly
     goldenFormat2 PNG "troublesome-polygon-under-rotation" 1 rotFunPoly
+
+  golden "shell" 0.5 $
+    let radius :: ℝ = 10
+        radius2 = radius * 2
+        shellWidth :: ℝ = 1
+    in
+      union
+        -- make a shell and slice the bottom off so we can inspect the wall
+        [ differenceR 0 (shell shellWidth $ sphere radius)
+          [ translate (V3 (-radius) (-radius) (-radius)) $ cube False (V3 radius2 radius2 radius)
+          ]
+        -- Make a cube with the same radius as the sphere and moved upwards
+        -- so that it is just touching the top of the sphere. This lets us
+        -- easily check if the radius is being messed with for some reason.
+        -- The render quality will need to be increased a lot to actually see
+        -- if this is working, but you will get a feel for when it is correct
+        -- and the STL is just showing resolution limits
+        , translate (V3 (-radius) (-radius) radius) . cube False $ V3 radius2 radius2 radius
+        -- Make a cube with the same dimentions as the shell thickness
+        -- and place it on the lip of the shell so we can check if the thickness
+        -- is actually correct
+        , translate (V3 (radius-shellWidth) (-(shellWidth/2)) (-shellWidth)) . cube False $
+          V3 shellWidth shellWidth shellWidth
+        ]