Merge pull request #469 from Haskell-Things/lepsa/bounding-boxes

fix bounding boxes for infinite implicit functions.

CHANGELOG.md

@@ -2,6 +2,7 @@
 
 * Other changes
   * Fixing `shell` so that it doesn't increase the outside dimentions of objects.
+  * Fixing an issue with bounding boxes for infinite functions. [#412](https://github.com/Haskell-Things/ImplicitCAD/issues/412)
 
 # 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/Primitives.hs

@@ -53,7 +53,7 @@ module Graphics.Implicit.Primitives (
                                      pattern Shared,
                                      Object(Space, canonicalize)) where
 
-import Prelude(Applicative, Eq, Foldable, Num, abs, (<), otherwise, Num, (+), (-), (*), (/), (.), negate, Bool(True, False), Maybe(Just, Nothing), Either, fmap, ($), (**), sqrt)
+import Prelude(Applicative, Eq, Foldable, Num, abs, (<), otherwise, Num, (+), (-), (*), (/), (.), negate, Bool(True, False), Maybe(Just, Nothing), Either, fmap, ($), (**), sqrt, (<=), (&&), max, Ord)
 
 import Graphics.Implicit.Canon (canonicalize2, canonicalize3)
 import Graphics.Implicit.Definitions (ObjectContext, ℝ, ℝ2, ℝ3, Box2,
@@ -95,7 +95,7 @@ import Graphics.Implicit.Definitions (ObjectContext, ℝ, ℝ2, ℝ3, Box2,
                                       ExtrudeMScale,
                                       defaultObjectContext
                                      )
-import Graphics.Implicit.MathUtil   (pack)
+import Graphics.Implicit.MathUtil   (pack, infty)
 import Graphics.Implicit.ObjectUtil (getBox2, getBox3, getImplicit2, getImplicit3)
 import Linear (M33, M44, V2(V2),V3(V3), axisAngle, Quaternion)
 import Control.Lens (prism', Prism', preview, (#))
@@ -197,6 +197,7 @@ class ( Applicative f
       , Eq a
       , Eq (f a)
       , Foldable f
+      , Ord a
       , Num a
       , Num (f a))
       => Object obj f a | obj -> f a
@@ -224,6 +225,10 @@ class ( Applicative f
     -- | Canonicalization function used to rewrite / normalize
     -- abstract syntax tree representing an object
     canonicalize :: obj -> obj
+    implicit
+      :: (f a -> a)  -- ^ Implicit function
+      -> (f a, f a)  -- ^ Bounding box
+      -> obj         -- ^ Resulting object
 
 -- | Get the implicit function for an object
 getImplicit
@@ -338,13 +343,6 @@ intersectR
     -> obj   -- ^ Resulting object
 intersectR r ss = Shared $ IntersectR r ss
 
-implicit
-    :: Object obj f a
-    => (f a -> a)  -- ^ Implicit function
-    -> (f a, f a)  -- ^ Bounding box
-    -> obj         -- ^ Resulting object
-implicit a b = Shared $ EmbedBoxedObj (a, b)
-
 instance Object SymbolicObj2 V2 ℝ where
   type Space SymbolicObj2 = V2
   _Shared = prism' Shared2 $ \case
@@ -354,6 +352,15 @@ instance Object SymbolicObj2 V2 ℝ where
   getImplicit' ctx = getImplicit2 ctx . canonicalize
   canonicalize = canonicalize2
 
+  implicit a b = Shared $ EmbedBoxedObj
+    ( \p -> max (a p) (if pointInBox b p then -infty else 1)
+    , b
+    )
+    where
+      pointInBox (V2 lx ly, V2 ux uy) (V2 x y) =
+        lx <= x && x <= ux &&
+        ly <= y && y <= uy
+
 instance Object SymbolicObj3 V3 ℝ where
   type Space SymbolicObj3 = V3
   _Shared = prism' Shared3 $ \case
@@ -363,6 +370,16 @@ instance Object SymbolicObj3 V3 ℝ where
   getImplicit' ctx = getImplicit3 ctx . canonicalize
   canonicalize = canonicalize3
 
+  implicit a b = Shared $ EmbedBoxedObj
+    ( \p -> max (a p) (if pointInBox b p then -infty else 1)
+    , b
+    )
+    where
+      pointInBox (V3 lx ly lz, V3 ux uy uz) (V3 x y z) =
+        lx <= x && x <= ux &&
+        ly <= y && y <= uy &&
+        lz <= z && z <= uz
+
 union :: Object obj f a => [obj] -> obj
 union = unionR 0
 

Graphics/Implicit/Primitives.hs-boot

@@ -1,5 +1,4 @@
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -12,7 +11,7 @@ module Graphics.Implicit.Primitives (Object(getBox, getImplicit', Space, _Shared
 import Graphics.Implicit.Definitions (ObjectContext, SymbolicObj2, SymbolicObj3, SharedObj, ℝ)
 import Control.Lens (Prism')
 import Data.Kind (Type)
-import Prelude (Applicative, Eq, Foldable, Num)
+import Prelude (Applicative, Eq, Foldable, Num, Ord)
 import Linear (V2, V3)
 
 -- See the non-source version of "Graphics.Implicit.Primitives" for
@@ -21,6 +20,7 @@ class ( Applicative f
       , Eq a
       , Eq (f a)
       , Foldable f
+      , Ord a
       , Num a
       , Num (f a)
       )
@@ -31,6 +31,7 @@ class ( Applicative f
     getBox       :: obj -> (f a, f a)
     getImplicit' :: ObjectContext -> obj -> (f a -> a)
     canonicalize :: obj -> obj
+    implicit     :: (f a -> a) -> (f a, f a) -> obj
 
 getImplicit :: Object obj f a => obj -> (f a -> a)
 

tests/GoldenSpec/Spec.hs

@@ -244,3 +244,35 @@ spec = describe "golden tests" $ do
         , translate (V3 (radius-shellWidth) (-(shellWidth/2)) (-shellWidth)) . cube False $
           V3 shellWidth shellWidth shellWidth
         ]
+
+  -- https://github.com/Haskell-Things/ImplicitCAD/issues/412
+  golden "boundingBoxes" 0.5 $
+    let
+      circle_diameter_bottom :: ℝ
+      circle_diameter_bottom = 14.80 -- mm
+      circle_height :: ℝ
+      circle_height = 9.86
+
+      root :: ℝ -> ℝ -> ℝ
+      root n x = x ** (1/n)
+
+      shape :: ℝ -> ℝ -> ℝ -> V2 ℝ -> ℝ
+      shape n width height (V2 x y) =
+          1 - root n ((x / half width) ** n + (y / half height) ** n)
+
+      half k = k / 2
+      twice k = 2 * k
+
+      test_shape :: ℝ -> SymbolicObj2
+      test_shape k =
+          intersect
+          [ implicit
+              (shape k circle_diameter_bottom (twice circle_height))
+              (V2 (-9) (-5), V2 9 10)
+              -- (pure (-infty), pure infty)
+          , rect (V2 (-15) 0) (V2 15 25)
+          ]
+
+      test_solid :: ℝ -> SymbolicObj3
+      test_solid k = extrude (test_shape k) 7
+    in test_solid 2