add polyhedron support.

CHANGELOG.md

@@ -1,6 +1,7 @@
 # Version [next](https://github.com/Haskell-Things/ImplicitCAD/compare/v0.4.1.0...master) (202Y-MM-DD)
 
 * ExtOpenScad interface changes
+  * Added `polyhedron()` support [#497](https://github.com/Haskell-Things/ImplicitCAD/pull/497)
   * Added `projection(cut=true)` support [#448](https://github.com/Haskell-Things/ImplicitCAD/pull/448)
 
 * Haskell interface changes

Examples/example26-Polyhedron.scad

@@ -0,0 +1,24 @@
+module pyramid(base, height) {
+  half = base / 2;
+
+  polyhedron(
+    points = [
+      [-half, -half, 0],
+      [ half, -half, 0],
+      [ half,  half, 0],
+      [-half,  half, 0],
+      [0, 0, height]
+    ],
+    faces = [
+      [0, 1, 2, 3],
+      [0, 1, 4],
+      [1, 2, 4],
+      [2, 3, 4],
+      [3, 0, 4]
+    ]
+  );
+}
+
+pyramid_base = 12;
+pyramid_height = 14;
+pyramid(pyramid_base, pyramid_height);

Graphics/Implicit/Canon.hs

@@ -83,6 +83,7 @@ import Graphics.Implicit.Definitions
   , SymbolicObj3
       ( Cube
       , Cylinder
+      , Polyhedron
       , Extrude
       , ExtrudeM
       , ExtrudeOnEdgeOf
@@ -176,6 +177,7 @@ fmapObj3
 fmapObj3 f _ _ (Cube v) = f $ Cube v
 fmapObj3 f _ _ (Sphere r) = f $ Sphere r
 fmapObj3 f _ _ (Cylinder r1 r2 h) = f $ Cylinder r1 r2 h
+fmapObj3 f _ _ (Polyhedron points faces) = f $ Polyhedron points faces
 fmapObj3 f _ _ (Torus r1 r2) = f $ Torus r1 r2
 fmapObj3 f _ _ (Ellipsoid a b c) = f $ Ellipsoid a b c
 fmapObj3 f _ _ (BoxFrame b e) = f $ BoxFrame b e
@@ -239,6 +241,7 @@ instance EqObj SymbolicObj3 where
   Ellipsoid a1 b1 c1 =^= Ellipsoid a2 b2 c2 = a1 == a2 && b1 == b2 && c1 == c2
   Cylinder r1a r2a ha =^= Cylinder r1b r2b hb = r1a == r1b && r2a == r2b && ha == hb
   BoxFrame b1 e1 =^= BoxFrame b2 e2 = b1 == b2 && e1 == e2
+  Polyhedron p1 f1 =^= Polyhedron p2 f2 = p1 == p2 && f1 == f2
   Link a1 b1 c1 =^= Link a2 b2 c2 = a1 == a2 && b1 == b2 && c1 == c2
   Rotate3 x a =^= Rotate3 y b = x == y && a =^= b
   Transform3 x a =^= Transform3 y b = x == y && a =^= b

Graphics/Implicit/Definitions.hs

@@ -56,6 +56,7 @@ module Graphics.Implicit.Definitions (
         Cube,
         Sphere,
         Cylinder,
+        Polyhedron,
         Rotate3,
         Transform3,
         Torus,
@@ -331,6 +332,7 @@ data SymbolicObj3 =
       Cube ℝ3 -- rounding, size.
     | Sphere ℝ -- radius
     | Cylinder ℝ ℝ ℝ --
+    | Polyhedron [ℝ3] [(ℕ,ℕ,ℕ)] -- vertexes, triangles-by-index
     -- Simple transforms
     | Rotate3 (Quaternion ℝ) SymbolicObj3
     | Transform3 (M44 ℝ) SymbolicObj3
@@ -364,6 +366,7 @@ instance Show SymbolicObj3 where
     -- centered.
     Cube sz -> showCon "cube" @| False @| sz
     Sphere d -> showCon "sphere" @| d
+    Polyhedron points tris -> showCon "polyhedron" @| points @| tris
     BoxFrame b e -> showCon "boxFrame" @| b @| e
     Link le r1 r2 -> showCon "link" @| le @| r1 @| r2
     -- NB: The arguments to 'Cylinder' are backwards compared to 'cylinder' and

Graphics/Implicit/Export/SymbolicFormats.hs

@@ -11,8 +11,9 @@ module Graphics.Implicit.Export.SymbolicFormats (scad2, scad3) where
 
 import Prelude((.), fmap, Either(Left, Right), ($), (*), (-), (/), pi, error, (+), (==), take, floor, (&&), const, (<>), (<$>))
 
-import Graphics.Implicit.Definitions(ℝ, SymbolicObj2(Shared2, Square, Circle, Polygon, Rotate2, Transform2, Slice), SymbolicObj3(Shared3, Cube, Sphere, Cylinder, BoxFrame, Rotate3, Transform3, Extrude, ExtrudeM, RotateExtrude, ExtrudeOnEdgeOf, Torus, Ellipsoid, Link), isScaleID, SharedObj(Empty, Full, Complement, UnionR, IntersectR, DifferenceR, Translate, Scale, Mirror, Outset, Shell, EmbedBoxedObj, WithRounding), quaternionToEuler)
-import Graphics.Implicit.Export.TextBuilderUtils(Text, bf)
+import Graphics.Implicit.Definitions(ℝ, SymbolicObj2(Shared2, Square, Circle, Polygon, Rotate2, Transform2, Slice), SymbolicObj3(Shared3, Cube, Sphere, Cylinder, Polyhedron, BoxFrame, Rotate3, Transform3, Extrude, ExtrudeM, RotateExtrude, ExtrudeOnEdgeOf, Torus, Ellipsoid, Link), isScaleID, SharedObj(Empty, Full, Complement, UnionR, IntersectR, DifferenceR, Translate, Scale, Mirror, Outset, Shell, EmbedBoxedObj, WithRounding), quaternionToEuler)
+
+import Graphics.Implicit.Export.TextBuilderUtils(Text, bf, bℕ)
 
 -- For constructing vectors of ℝs.
 import Linear (V2(V2), V3(V3), V4(V4))
@@ -131,11 +132,16 @@ buildS3 _ (Cube (V3 w d h)) = call "cube" [pretty $ bf w, pretty $ bf d, pretty
 
 buildS3 _ (Sphere r) = callNaked "sphere" ["r = " <> pretty (bf r)] []
 
-buildS3 _ (Cylinder h r1 r2) = callNaked "cylinder" [
-                              "r1 = " <> pretty (bf r1)
-                             ,"r2 = " <> pretty (bf r2)
-                             , pretty $ bf h
-                             ] []
+buildS3 _ (Cylinder h r1 r2) = callNaked "cylinder" ["r1 = " <> pretty (bf r1)
+                                                    ,"r2 = " <> pretty (bf r2)
+                                                    , pretty $ bf h
+                                                    ] []
+
+buildS3 _ (Polyhedron points tris) = callNaked "polyhedron" ["points = [" <> (fold $ intersperse "," $ renderPoint <$> points) <> "], faces = [" <> (fold $ intersperse "," $ renderTri <$> tris) <> "]" ] []
+  where
+    renderPoint (V3 v1 v2 v3) = "[" <> pretty (bf v1) <> "," <> pretty (bf v2) <> "," <> pretty (bf v3) <> "]"
+    renderTri (n1,n2,n3) = "[" <> pretty (bℕ n1) <> "," <> pretty (bℕ n2) <> "," <> pretty (bℕ n3) <> "]"
+
 buildS3 res (Rotate3 q obj) =
   let (V3 x y z) = quaternionToEuler q
    in call "rotate" [pretty $ bf (rad2deg x), pretty $ bf (rad2deg y), pretty $ bf (rad2deg z)] [buildS3 res obj]
@@ -180,7 +186,7 @@ buildS2 res (Shared2 obj) = buildShared res obj
 
 buildS2 _ (Circle r) = call "circle" [pretty $ bf r] []
 
-buildS2 _ (Polygon points) = call "polygon" (fmap bvect points) []
+buildS2 _ (Polygon points) = call "polygon" (bvect <$> points) []
 
 buildS2 res (Rotate2 r obj)     = call "rotate" [pretty $ bf (rad2deg r)] [buildS2 res obj]
 

Graphics/Implicit/Export/TextBuilderUtils.hs

@@ -13,6 +13,7 @@ module Graphics.Implicit.Export.TextBuilderUtils (
      toLazyText,
      -- some special case Builders.
      bf,
+     bℕ,
      buildTruncFloat,
      buildℕ,
      buildInt
@@ -37,6 +38,10 @@ toLazyText = toLazyTextWith defaultChunkSize
 bf :: ℝ -> Text
 bf value = toLazyText . formatRealFloat Exponent Nothing $ fromℝtoFloat value
 
+-- | Serialize a value as an Integer.
+bℕ :: ℕ -> Text
+bℕ = toLazyText . decimal
+
 -- | Serialize a float with four decimal places
 buildTruncFloat :: ℝ -> Builder
 buildTruncFloat = formatRealFloat Fixed $ Just 4

Graphics/Implicit/ExtOpenScad/Definitions.hs

@@ -20,7 +20,7 @@ module Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch
                                                   Expr(LitE, Var, ListE, LamE, (:$)),
                                                   StatementI(StatementI),
                                                   Statement(DoNothing, NewModule, Include, If, ModuleCall, (:=)),
-                                                  OVal(OIO, ONum, OBool, OString, OList, OFunc, OUndefined, OUModule, ONModule, OVargsModule, OError, OObj2, OObj3),
+                                                  OVal(OIO, ONum, OBool, OString, OList, OFunc, OUndefined, OUModule, ONModule, ONModuleWithSuite, OVargsModule, OError, OObj2, OObj3),
                                                   TestInvariant(EulerCharacteristic),
                                                   SourcePosition(SourcePosition),
                                                   StateC,
@@ -37,7 +37,7 @@ module Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch
                                                   CanCompState'
                                                   ) where
 
-import Prelude(Eq, Show, Ord, Maybe(Just), Bool(True, False), IO, FilePath, (==), show, ($), (<>), and, zipWith, Int, (<$>))
+import Prelude(Eq, Show, Ord, Maybe, Bool(True, False), IO, FilePath, (==), show, ($), (<>), and, zipWith, Int, (<$>))
 
 -- Resolution of the world, Integer type, and symbolic languages for 2D and 3D objects.
 import Graphics.Implicit.Definitions (ℝ, ℕ, Fastℕ, SymbolicObj2, SymbolicObj3, fromFastℕ)
@@ -119,6 +119,7 @@ data ArgParser a
                  -- ^ For returns: @APTerminator (return value)@
                  | APFail Text
                  -- ^ For failure: @APFail (error message)@
+                 -- NOTE: we don't use APFail to fail parsing in Primitives.hs, we have errorC.
                  | APExample Text (ArgParser a)
                  -- ^ An example, then next
                  | APTest Text [TestInvariant] (ArgParser a)
@@ -197,8 +198,10 @@ data OVal = OUndefined
          | OIO (IO OVal)
          -- Name, arguments, argument parsers.
          | OUModule Symbol (Maybe [(Symbol, Bool)]) (VarLookup -> ArgParser (StateC [OVal]))
-         -- Name, implementation, arguments, whether the module accepts/requires a suite.
-         | ONModule Symbol (SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) [([(Symbol, Bool)],  Maybe Bool)]
+         -- Name, implementation, arguments.
+         | ONModule Symbol (SourcePosition -> ArgParser (StateC [OVal])) [[(Symbol, Bool)]]
+         -- Name, implementation, arguments.
+         | ONModuleWithSuite Symbol (SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) [[(Symbol, Bool)]]
          | OVargsModule Symbol (Symbol -> SourcePosition -> [(Maybe Symbol, OVal)] -> [StatementI] -> ([StatementI] -> StateC ()) -> StateC ())
          | OObj3 SymbolicObj3
          | OObj2 SymbolicObj2
@@ -230,18 +233,23 @@ instance Show OVal where
         showArg (Symbol a, hasDefault) = if hasDefault
                                          then a
                                          else a <> "=..."
-        showInstances :: [([(Symbol, Bool)], Maybe Bool)] -> Text
+        showInstances :: [[(Symbol, Bool)]] -> Text
         showInstances [] = ""
         showInstances [oneInstance] = "module " <> name <> showInstance oneInstance
         showInstances multipleInstances = "Module " <> name <> "[ " <> intercalate ", " (showInstance <$> multipleInstances) <> " ]"
-        showInstance :: ([(Symbol, Bool)], Maybe Bool) -> Text
-        showInstance (arguments, suiteInfo) = " (" <> intercalate ", " (showArg <$> arguments) <> ") {}" <> showSuiteInfo suiteInfo
-        showSuiteInfo :: Maybe Bool -> Text
-        showSuiteInfo suiteInfo = case suiteInfo of
-                          Just requiresSuite -> if requiresSuite
-                                                then " requiring suite {}"
-                                                else " accepting suite {}"
-                          _ -> ""
+        showInstance :: [(Symbol, Bool)] -> Text
+        showInstance arguments = " (" <> intercalate ", " (showArg <$> arguments) <> ") "
+    show (ONModuleWithSuite (Symbol name) _ instances) = unpack $ showInstances instances
+      where
+        showArg (Symbol a, hasDefault) = if hasDefault
+                                         then a
+                                         else a <> "=..."
+        showInstances :: [[(Symbol, Bool)]] -> Text
+        showInstances [] = ""
+        showInstances [oneInstance] = "module " <> name <> showInstance oneInstance
+        showInstances multipleInstances = "Module " <> name <> "[ " <> intercalate ", " (showInstance <$> multipleInstances) <> " ]"
+        showInstance :: [(Symbol, Bool)] -> Text
+        showInstance arguments = " (" <> intercalate ", " (showArg <$> arguments) <> ") {} requiring suite {}"
     show (OVargsModule (Symbol name) _) = "varargs module " <> unpack name
     show (OError msg) = unpack $ "Execution Error:\n" <> msg
     show (OObj2 obj) = "<obj2: " <> show obj <> ">"

Graphics/Implicit/ExtOpenScad/Eval/Statement.hs

@@ -13,7 +13,7 @@ import Graphics.Implicit.ExtOpenScad.Definitions (
                                                   Statement(Include, (:=), If, NewModule, ModuleCall, DoNothing),
                                                   Pattern(Name),
                                                   Expr(LitE),
-                                                  OVal(OBool, OUModule, ONModule, OVargsModule),
+                                                  OVal(OBool, OUModule, ONModule, ONModuleWithSuite, OVargsModule),
                                                   VarLookup(VarLookup),
                                                   StatementI(StatementI),
                                                   Symbol(Symbol),
@@ -116,15 +116,23 @@ runStatementI (StatementI sourcePos (ModuleCall (Symbol name) argsExpr suite)) =
               fromMaybe (pure []) (fst argsMapped)
             Just (ONModule _ implementation forms) -> do
               possibleInstances <- selectInstances forms
-              let
-                suiteInfo = case possibleInstances of
-                  [(_, suiteInfoFound)]   -> suiteInfoFound
-                  []                      -> Nothing
-                  ((_, suiteInfoFound):_) -> suiteInfoFound
               when (null possibleInstances) (do
                                                 errorC sourcePos $ "no instance of " <> name <> " found to match given parameters.\nInstances available:\n" <> pack (show (ONModule (Symbol name) implementation forms))
-                                                traverse_ ((`checkOptions` True) . Just . fst) forms
+                                                traverse_ ((`checkOptions` True) . Just) forms
                                             )
+              -- Evaluate all of the arguments.
+              evaluatedArgs <- evalArgs argsExpr
+              when (suite /= []) (errorC sourcePos $ "Suite provided, but module " <> name <> " does not accept one. Perhaps a missing semicolon?")
+              -- Run the module.
+              let
+                argsMapped = argMap evaluatedArgs $ implementation sourcePos
+              for_ (pack <$> snd argsMapped) $ errorC sourcePos
+              fromMaybe (pure []) $ fst argsMapped
+            Just (ONModuleWithSuite _ implementation forms) -> do
+              possibleInstances <- selectInstances forms
+              when (null possibleInstances) $ do
+                                              errorC sourcePos $ "no instance of " <> name <> " found to match given parameters.\nInstances available:\n" <> pack (show (ONModuleWithSuite (Symbol name) implementation forms))
+                                              traverse_ ((`checkOptions` True) . Just) forms
               -- Ignore this for now, because all instances we define have the same suite requirements.
               {-
               when (length possibleInstances > 1) (do
@@ -135,14 +143,9 @@ runStatementI (StatementI sourcePos (ModuleCall (Symbol name) argsExpr suite)) =
               evaluatedArgs <- evalArgs argsExpr
               -- Evaluate the suite.
               vals <- runSuiteCapture varlookup suite
-              suiteResults <- case suiteInfo of
-                              Just True -> do
-                                when (null vals) (errorC sourcePos "Suite required, but none provided.")
-                                pure vals
-                              Just False -> pure vals
-                              _ -> do
-                                when (suite /= []) (errorC sourcePos $ "Suite provided, but module " <> name <> " does not accept one. Perhaps a missing semicolon?")
-                                pure []
+              suiteResults <- do
+                              when (null vals) (errorC sourcePos "Suite required, but none provided.")
+                              pure vals
               -- Run the module.
               let
                 argsMapped = argMap evaluatedArgs $ implementation sourcePos suiteResults
@@ -164,12 +167,12 @@ runStatementI (StatementI sourcePos (ModuleCall (Symbol name) argsExpr suite)) =
                 pure []
         pushVals newVals
           where
-            selectInstances :: [([(Symbol, Bool)], Maybe Bool)] -> StateC [([(Symbol, Bool)], Maybe Bool)]
+            selectInstances :: [[(Symbol, Bool)]] -> StateC [[(Symbol, Bool)]]
             selectInstances instances = do
               validInstances <- for instances
-                    ( \(args, suiteInfo) -> do
+                    ( \args -> do
                         res <- checkOptions (Just args) False
-                        pure $ if res then Just (args, suiteInfo) else Nothing
+                        pure $ if res then Just args else Nothing
                     )
               pure $ catMaybes validInstances
             checkOptions :: Maybe [(Symbol, Bool)] -> Bool -> StateC Bool