diff --git a/CHANGELOG.md b/CHANGELOG.md index 37948a12..426d319d 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/Examples/example26-Polyhedron.scad b/Examples/example26-Polyhedron.scad new file mode 100644 index 00000000..2471f125 --- /dev/null +++ b/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); diff --git a/Graphics/Implicit/Canon.hs b/Graphics/Implicit/Canon.hs index 0cb72d62..1f234145 100644 --- a/Graphics/Implicit/Canon.hs +++ b/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 diff --git a/Graphics/Implicit/Definitions.hs b/Graphics/Implicit/Definitions.hs index 5153e0dc..73f87aa6 100644 --- a/Graphics/Implicit/Definitions.hs +++ 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 diff --git a/Graphics/Implicit/Export/SymbolicFormats.hs b/Graphics/Implicit/Export/SymbolicFormats.hs index 6c5018e9..1869389a 100644 --- a/Graphics/Implicit/Export/SymbolicFormats.hs +++ b/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] diff --git a/Graphics/Implicit/Export/TextBuilderUtils.hs b/Graphics/Implicit/Export/TextBuilderUtils.hs index efc4ac4f..f9daae56 100644 --- a/Graphics/Implicit/Export/TextBuilderUtils.hs +++ b/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 diff --git a/Graphics/Implicit/ExtOpenScad/Definitions.hs b/Graphics/Implicit/ExtOpenScad/Definitions.hs index 73e4b20f..352943d4 100644 --- a/Graphics/Implicit/ExtOpenScad/Definitions.hs +++ b/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) = " show obj <> ">" diff --git a/Graphics/Implicit/ExtOpenScad/Eval/Statement.hs b/Graphics/Implicit/ExtOpenScad/Eval/Statement.hs index d2701e09..6c6fb95d 100644 --- a/Graphics/Implicit/ExtOpenScad/Eval/Statement.hs +++ b/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 diff --git a/Graphics/Implicit/ExtOpenScad/Primitives.hs b/Graphics/Implicit/ExtOpenScad/Primitives.hs index cf0ce1c5..bd824892 100644 --- a/Graphics/Implicit/ExtOpenScad/Primitives.hs +++ b/Graphics/Implicit/ExtOpenScad/Primitives.hs @@ -15,11 +15,13 @@ -- Export one set containing all of the primitive modules. module Graphics.Implicit.ExtOpenScad.Primitives (primitiveModules) where -import Prelude((.), Either(Left, Right), Bool(True, False), Maybe(Just, Nothing), ($), pure, either, id, (-), (==), (&&), (<), (*), cos, sin, pi, (/), (>), const, uncurry, (/=), (||), not, null, fmap, (<>), otherwise, error, (<*>), (<$>)) +import Prelude(any, concat, elem, error, foldr, head, mapM, (.), Either(Left, Right), Bool(True, False), Maybe(Just, Nothing), ($), pure, show, either, id, (-), (==), (&&), (<), (*), cos, sin, pi, (/), (>), const, uncurry, (/=), (||), not, null, fmap, (<>), otherwise, (<*>), (<$>)) import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, ℕ, SymbolicObj2, SymbolicObj3, ExtrudeMScale(C1), fromℕtoℝ, isScaleID) -import Graphics.Implicit.ExtOpenScad.Definitions (OVal (OObj2, OObj3, ONModule), ArgParser(APFail), Symbol(Symbol), StateC, SourcePosition) +import Graphics.Implicit.Export.Util (centroid) + +import Graphics.Implicit.ExtOpenScad.Definitions (OVal (OObj2, OObj3, ONModule, ONModuleWithSuite), ArgParser, Symbol(Symbol), StateC, SourcePosition) import Graphics.Implicit.ExtOpenScad.Util.ArgParser (doc, defaultTo, example, test, eulerCharacteristic) @@ -27,21 +29,37 @@ import qualified Graphics.Implicit.ExtOpenScad.Util.ArgParser as GIEUA (argument import Graphics.Implicit.ExtOpenScad.Util.OVal (OTypeMirror, caseOType, divideObjs, (<||>)) -import Graphics.Implicit.ExtOpenScad.Util.StateC (errorC) +import Graphics.Implicit.ExtOpenScad.Util.StateC (errorC, warnC) + +import Graphics.Implicit.TriUtil (Tri) -- Note the use of a qualified import, so we don't have the functions in this file conflict with what we're importing. -import qualified Graphics.Implicit.Primitives as Prim (withRounding, sphere, rect3, rect, translate, circle, polygon, extrude, cylinder2, union, unionR, intersect, intersectR, difference, differenceR, rotate, slice, transform, rotate3V, rotate3, transform3, scale, extrudeM, rotateExtrude, shell, mirror, pack3, pack2, torus, ellipsoid, cone) +import qualified Graphics.Implicit.Primitives as Prim (withRounding, sphere, rect3, rect, translate, circle, polygon, polyhedron, extrude, cylinder2, union, unionR, intersect, intersectR, difference, differenceR, rotate, slice, transform, rotate3V, rotate3, transform3, scale, extrudeM, rotateExtrude, shell, mirror, pack3, pack2, torus, ellipsoid, cone) + +import Control.Monad (foldM, mplus) + +import Data.Foldable (toList) + +import Data.List (genericIndex) + +import Data.Maybe (fromMaybe, isJust) -import Control.Monad (when, mplus) +import Data.Sequence (Seq, deleteAt, filter, fromList) +import qualified Data.Sequence as DS (null) import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as DTL (pack) import Control.Lens ((^.)) -import Linear (_m33, M34, M44, V2(V2), V3(V3), V4(V4)) + +import Linear (_m33, cross, dot, M34, M44, V2(V2), V3(V3), V4(V4)) + import Linear.Affine (qdA) default (ℝ) +-- FIXME: `defaultTo` is used inconsistently. The line between defaults and examples is a bit blurry. + -- | Use the old syntax when defining arguments. argument :: OTypeMirror desiredType => Text -> ArgParser desiredType argument a = GIEUA.argument (Symbol a) @@ -50,43 +68,52 @@ argument a = GIEUA.argument (Symbol a) primitiveModules :: [(Symbol, OVal)] primitiveModules = [ - onModIze sphere [([("r", noDefault)], noSuite), ([("d", noDefault)], noSuite)] - , onModIze cube [([("x", noDefault), ("y", noDefault), ("z", noDefault), ("center", hasDefault), ("r", hasDefault)], noSuite),([("size", noDefault), ("center", hasDefault), ("r", hasDefault)], noSuite)] - , onModIze square [([("x", noDefault), ("y", noDefault), ("center", hasDefault), ("r", hasDefault)], noSuite), ([("size", noDefault), ("center", hasDefault), ("r", hasDefault)], noSuite)] - , onModIze cylinder [([("r", hasDefault), ("h", hasDefault), ("r1", hasDefault), ("r2", hasDefault), ("$fn", hasDefault), ("center", hasDefault)], noSuite), - ([("d", hasDefault), ("h", hasDefault), ("d1", hasDefault), ("d2", hasDefault), ("$fn", hasDefault), ("center", hasDefault)], noSuite)] - , onModIze circle [([("r", noDefault), ("$fn", hasDefault)], noSuite), ([("d", noDefault), ("$fn", hasDefault)], noSuite)] - , onModIze cone [([("r", noDefault), ("h", hasDefault), ("center", hasDefault)], noSuite), ([("d", noDefault), ("h", hasDefault), ("center", hasDefault)], noSuite)] - , onModIze torus [([("r1", noDefault), ("r2", hasDefault)], noSuite)] - , onModIze ellipsoid [([("a", noDefault), ("b", hasDefault), ("c", hasDefault)], noSuite)] - , onModIze polygon [([("points", noDefault)], noSuite)] - , onModIze union [([("r", hasDefault)], requiredSuite)] - , onModIze intersect [([("r", hasDefault)], requiredSuite)] - , onModIze difference [([("r", hasDefault)], requiredSuite)] - , onModIze translate [([("x", noDefault), ("y", noDefault), ("z", noDefault)], requiredSuite), ([("v", noDefault)], requiredSuite)] - , onModIze rotate [([("a", noDefault), ("v", hasDefault)], requiredSuite)] - , onModIze scale [([("v", noDefault)], requiredSuite)] - , onModIze extrude [([("height", hasDefault), ("center", hasDefault), ("twist", hasDefault), ("scale", hasDefault), ("translate", hasDefault), ("r", hasDefault)], requiredSuite)] - , onModIze rotateExtrude [([("angle", hasDefault), ("r", hasDefault), ("translate", hasDefault), ("rotate", hasDefault)], requiredSuite)] - , onModIze shell [([("w", noDefault)], requiredSuite)] - , onModIze projection [([("cut", hasDefault)], requiredSuite)] - , onModIze pack [([("size", noDefault), ("sep", noDefault)], requiredSuite)] - , onModIze unit [([("unit", noDefault)], requiredSuite)] - , onModIze mirror [([("x", noDefault), ("y", noDefault), ("z", noDefault)], requiredSuite), ([("v", noDefault)], requiredSuite)] - , onModIze multmatrix [([("m", noDefault)], requiredSuite)] + consModule sphere [[("r", noDefault)], [("d", noDefault)]] + , consModule cube [[("x", noDefault), ("y", noDefault), ("z", noDefault), ("center", hasDefault), ("r", hasDefault)],[("size", noDefault), ("center", hasDefault), ("r", hasDefault)]] + , consModule square [[("x", noDefault), ("y", noDefault), ("center", hasDefault), ("r", hasDefault)], [("size", noDefault), ("center", hasDefault), ("r", hasDefault)]] + , consModule cylinder [[("r", hasDefault), ("h", hasDefault), ("r1", hasDefault), ("r2", hasDefault), ("$fn", hasDefault), ("center", hasDefault)], + [("d", hasDefault), ("h", hasDefault), ("d1", hasDefault), ("d2", hasDefault), ("$fn", hasDefault), ("center", hasDefault)]] + , consModule circle [[("r", noDefault), ("$fn", hasDefault)], [("d", noDefault), ("$fn", hasDefault)]] + , consModule cone [[("r", noDefault), ("h", hasDefault), ("center", hasDefault)], [("d", noDefault), ("h", hasDefault), ("center", hasDefault)]] + , consModule torus [[("r1", noDefault), ("r2", hasDefault)]] + , consModule ellipsoid [[("a", noDefault), ("b", hasDefault), ("c", hasDefault)]] + , consModule polygon [[("points", noDefault)]] + , consModule polyhedron [[("points", noDefault), ("faces", noDefault)]] + , consModuleWithSuite union [[("r", hasDefault)]] + , consModuleWithSuite intersect [[("r", hasDefault)]] + , consModuleWithSuite difference [[("r", hasDefault)]] + , consModuleWithSuite translate [[("x", noDefault), ("y", noDefault), ("z", noDefault)], [("v", noDefault)]] + , consModuleWithSuite rotate [[("a", noDefault), ("v", hasDefault)]] + , consModuleWithSuite scale [[("v", noDefault)]] + , consModuleWithSuite extrude [[("height", hasDefault), ("center", hasDefault), ("twist", hasDefault), ("scale", hasDefault), ("translate", hasDefault), ("r", hasDefault)]] + , consModuleWithSuite rotateExtrude [[("angle", hasDefault), ("r", hasDefault), ("translate", hasDefault), ("rotate", hasDefault)]] + , consModuleWithSuite shell [[("w", noDefault)]] + , consModuleWithSuite projection [[("cut", hasDefault)]] + , consModuleWithSuite pack [[("size", noDefault), ("sep", noDefault)]] + , consModuleWithSuite unit [[("unit", noDefault)]] + , consModuleWithSuite mirror [[("x", noDefault), ("y", noDefault), ("z", noDefault)], [("v", noDefault)]] + , consModuleWithSuite multmatrix [[("m", noDefault)]] ] where hasDefault = True noDefault = False - noSuite :: Maybe Bool - noSuite = Nothing - requiredSuite = Just True - onModIze func rawInstances = (name, ONModule name implementation instances) + consModuleWithSuite :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -> [[(Text, Bool)]] -> (Symbol, OVal) + consModuleWithSuite func rawInstances = (name, ONModuleWithSuite name implementation instances) + where + (name, implementation) = func + instances = fmap fixup rawInstances + fixup :: [(Text, Bool)] -> [(Symbol, Bool)] + fixup args = fmap fixupArgs args + where + fixupArgs :: (Text, Bool) -> (Symbol, Bool) + fixupArgs (symbol, maybeDefault) = (Symbol symbol, maybeDefault) + consModule :: (Symbol, SourcePosition -> ArgParser (StateC [OVal])) -> [[(Text, Bool)]] -> (Symbol, OVal) + consModule func rawInstances = (name, ONModule name implementation instances) where (name, implementation) = func instances = fmap fixup rawInstances - fixup :: ([(Text, Bool)], Maybe Bool) -> ([(Symbol, Bool)], Maybe Bool) - fixup (args, suiteInfo) = (fmap fixupArgs args, suiteInfo) + fixup :: [(Text, Bool)] -> [(Symbol, Bool)] + fixup (args) = fmap fixupArgs args where fixupArgs :: (Text, Bool) -> (Symbol, Bool) fixupArgs (symbol, maybeDefault) = (Symbol symbol, maybeDefault) @@ -94,8 +121,8 @@ primitiveModules = -- | sphere is a module without a suite. -- this means that the parser will look for this like -- sphere(args...); -sphere :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -sphere = moduleWithoutSuite "sphere" $ \_ _ -> do +sphere :: (Symbol, SourcePosition -> ArgParser (StateC [OVal])) +sphere = moduleWithoutSuite "sphere" $ \_ -> do example "sphere(3);" example "sphere(r=5);" -- arguments: @@ -117,8 +144,8 @@ sphere = moduleWithoutSuite "sphere" $ \_ _ -> do -- | FIXME: square1, square2 like cylinder has? -- FIXME: translate for square2? -cube :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -cube = moduleWithoutSuite "cube" $ \_ _ -> do +cube :: (Symbol, SourcePosition -> ArgParser (StateC [OVal])) +cube = moduleWithoutSuite "cube" $ \_ -> do -- examples example "cube(size = [2,3,4], center = true, r = 0.5);" example "cube(4);" @@ -162,8 +189,8 @@ cube = moduleWithoutSuite "cube" $ \_ _ -> do -- Implementation addObj3 $ Prim.withRounding r $ Prim.rect3 (V3 x1 y1 z1) (V3 x2 y2 z2) -square :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -square = moduleWithoutSuite "square" $ \_ _ -> do +square :: (Symbol, SourcePosition -> ArgParser (StateC [OVal])) +square = moduleWithoutSuite "square" $ \_ -> do -- examples example "square(x=[-2,2], y=[-1,5]);" example "square(size = [3,4], center = true, r = 0.5);" @@ -203,8 +230,8 @@ square = moduleWithoutSuite "square" $ \_ _ -> do -- Implementation addObj2 $ Prim.withRounding r $ Prim.rect (V2 x1 y1) (V2 x2 y2) -cylinder :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -cylinder = moduleWithoutSuite "cylinder" $ \_ _ -> do +cylinder :: (Symbol, SourcePosition -> ArgParser (StateC [OVal])) +cylinder = moduleWithoutSuite "cylinder" $ \_ -> do example "cylinder(r=10, h=30, center=true);" example "cylinder(r1=4, r2=6, h=10);" example "cylinder(r=5, h=10, $fn = 6);" @@ -265,8 +292,97 @@ cylinder = moduleWithoutSuite "cylinder" $ \_ _ -> do in shift obj3 else shift $ Prim.cylinder2 r1 r2 dh -cone :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -cone = moduleWithoutSuite "cone" $ \_ _ -> do +polyhedron :: (Symbol, SourcePosition -> ArgParser (StateC [OVal])) +polyhedron = moduleWithoutSuite "polyhedron" $ \sourcePos -> do + example "polyhedron(points=[[0,0,0], [2,0,0], [2,2,0], [0,2,0], [1, 1, 2]], faces=[[0,1,2,3], [0,4,1], [1,4,2], [2,4,3], [3,4,0]]);" + -- Arguments + -- FIXME: find a way to mark an arguement as non-empty! + points :: [ℝ3] <- argument "points" `doc` "list of points to construct faces from" + faces :: [[ℕ]] <- argument "faces" `doc` "list of sets of indices into points, used to create faces on the polyhedron." + pure $ do + -- A tri is constructed of three indexes into the points. + tris <- fmap concat $ mapM (trianglesFromFace sourcePos) faces + woundTris <- reWindTriangles sourcePos points tris + pure [OObj3 $ Prim.polyhedron points woundTris] + where + -- decompose our faces into tris. + trianglesFromFace :: SourcePosition -> [ℕ] -> StateC [Tri] + trianglesFromFace sourcePos [] = do + warnC sourcePos "no point found when trying to generate triangles from a face.\n" + pure [] + trianglesFromFace sourcePos [p1] = do + errorC sourcePos $ "only one point found: " <> (DTL.pack $ show p1) <> "\n" + pure [] + trianglesFromFace sourcePos [p1,p2] = do + errorC sourcePos $ "only two points found: " <> (DTL.pack $ show p1) <> "\n" <> (DTL.pack $ show p2) <> "\n" + pure [] + trianglesFromFace _ [p1,p2,p3] = pure [(p1,p2,p3)] + trianglesFromFace sourcePos (p1:p2:p3:xs) = ((p1,p2,p3):) <$> trianglesFromFace sourcePos (p1:p3:xs) + -- | Ensure our triangles are wound in the same direction + reWindTriangles :: SourcePosition -> [ℝ3] -> [Tri] -> StateC [Tri] + reWindTriangles _ _ [] = pure [] + -- Really, forces them to have the same winding as the first triangle, from us putting [safeTri] here. + reWindTriangles sourcePos points (firstTri:moreTris) = windTriangles [safeTri] (fromList moreTris) + where + -- The first triangle, flipped based on comparing two centroids. + safeTri + | (triCentroid - polyCentroid) `dot` triNorm < 0 = flipTri firstTri + | otherwise = firstTri + where + (p1,p2,p3) = firstTri + (v1,v2,v3) = (genericIndex points p1,genericIndex points p2,genericIndex points p3) + -- The norm of the safe triangle. + triNorm = (v2-v1) `cross` (v3-v1) + triCentroid = centroid [v1,v2,v3] + polyCentroid = centroid points + flipTri (p1,p2,p3) = (p1,p3,p2) + -- | Wind the triangles. For two triangles sharing an edge, said edge MUST be expressed by the two triangles in the opposite order. + windTriangles :: [Tri] -> Seq Tri -> StateC [Tri] + windTriangles visited unvisited + -- We're done. + | DS.null unvisited = pure visited + | otherwise = do + (newVisited, newUnvisited) <- foldM (classifyTri visited) ([], unvisited) (toList unvisited) + if null newVisited + then do + warnC sourcePos $ "Had to pick a new root, incomplete polyhedron?" + windTriangles (visited <> [head $ toList newUnvisited]) (deleteAt 0 newUnvisited) + else windTriangles (visited <> newVisited) newUnvisited + -- | Compare one unvisited triangle against all visited triangles. + -- If it's a neighbor of a visited triangle, correct it's winding and throw a warning if we had to flip it, then move it from unvisited to found (after flipping). + classifyTri :: [Tri] -> ([Tri], Seq Tri) -> Tri -> StateC ([Tri], Seq Tri) + classifyTri visited (found, remaining) triUnderTest = + case res of + Just triFound -> do -- See if we flipped our tri, and if so, throw a warning. + if triFound /= triUnderTest + then warnC sourcePos $ "Flipped face detected with vertices " <> (DTL.pack $ show triUnderTest) + else pure () + pure (found <> [triFound], filter (/= triUnderTest) remaining) + Nothing -> pure (found, remaining) + where + res = foldr (\tri state -> firstNeighborFilter tri triUnderTest state) Nothing visited + -- | A short-circuiting filter we fold over visited, and grab the first neighboring tri. + firstNeighborFilter :: Tri -> Tri -> Maybe Tri -> Maybe Tri + firstNeighborFilter src testTri maybeRes + | isJust maybeRes = maybeRes + | otherwise = maybeWindNeighbor src testTri + -- | Checks whether a triangle under test is a neighbor of the given triangle, and if it is, returns if after ensuring it is wound in the proper direction. + maybeWindNeighbor :: Tri -> Tri -> Maybe Tri + maybeWindNeighbor src testTri + -- A correctly wound neighbor will have the opposite direction, when it is referring to a given edge. + | oppositeNeighbor = Just testTri + -- A neighbor that needs flipped will refer to an edge in the same direction as our given triangle. + | sameNeighbor = Just $ flipTri testTri + | otherwise = Nothing + where + oppositeNeighbor = any (\edge -> flip edge `elem` edgesOfTri src) $ edgesOfTri testTri + where + flip (a,b) = (b,a) + sameNeighbor = any (\edge -> edge `elem` edgesOfTri src) $ edgesOfTri testTri + edgesOfTri (p1,p2,p3) = [(p1,p2), (p2,p3), (p3,p1)] + +cone :: (Symbol, SourcePosition -> ArgParser (StateC [OVal])) +cone = moduleWithoutSuite "cone" $ \_ -> do example "cone(r=10, h=30, center=true);" -- arguments r <- do @@ -296,8 +412,8 @@ cone = moduleWithoutSuite "cone" $ \_ _ -> do else Prim.translate (V3 0 0 h1) addObj3 . shift $ Prim.cone r dh -torus :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -torus = moduleWithoutSuite "torus" $ \_ _ -> do +torus :: (Symbol, SourcePosition -> ArgParser (StateC [OVal])) +torus = moduleWithoutSuite "torus" $ \_ -> do example "torus(r1=10, r2=5);" -- arguments (r1, r2) <- (,) @@ -310,8 +426,8 @@ torus = moduleWithoutSuite "torus" $ \_ _ -> do -- based on the args. addObj3 $ Prim.torus r1 r2 -ellipsoid :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -ellipsoid = moduleWithoutSuite "ellipsoid" $ \_ _ -> do +ellipsoid :: (Symbol, SourcePosition -> ArgParser (StateC [OVal])) +ellipsoid = moduleWithoutSuite "ellipsoid" $ \_ -> do example "ellipsoid(a=1, b=2, c=3);" -- arguments (a, b, c) <- (,,) @@ -325,8 +441,8 @@ ellipsoid = moduleWithoutSuite "ellipsoid" $ \_ _ -> do -- based on the args. addObj3 $ Prim.ellipsoid a b c -circle :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -circle = moduleWithoutSuite "circle" $ \_ _ -> do +circle :: (Symbol, SourcePosition -> ArgParser (StateC [OVal])) +circle = moduleWithoutSuite "circle" $ \_ -> do example "circle(r=10); // circle" example "circle(r=5, $fn=6); //hexagon" -- Arguments @@ -351,12 +467,11 @@ circle = moduleWithoutSuite "circle" $ \_ _ -> do else Prim.polygon [V2 (r*cos θ) (r*sin θ) | θ <- [2*pi*fromℕtoℝ n/fromℕtoℝ sides | n <- [0 .. sides - 1]]] --- | FIXME: 3D Polygons? --- FIXME: handle rectangles that are not grid alligned. +-- | FIXME: handle rectangles that are not grid alligned. -- FIXME: allow for rounding of polygon corners, specification of vertex ordering. -- FIXME: polygons have to have more than two points, or do not generate geometry, and generate an error. -polygon :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -polygon = moduleWithoutSuite "polygon" $ \_ _ -> do +polygon :: (Symbol, SourcePosition -> ArgParser (StateC [OVal])) +polygon = moduleWithoutSuite "polygon" $ \_ -> do example "polygon ([(0,0), (0,10), (10,0)]);" points :: [ℝ2] <- argument "points" `doc` "vertices of the polygon" @@ -412,23 +527,26 @@ intersect = moduleWithSuite "intersection" $ \_ children -> do else objReduce Prim.intersect Prim.intersect children difference :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -difference = moduleWithSuite "difference" $ \_ children -> do - when (null children) $ APFail "Call to 'difference' requires at least one child" +difference = moduleWithSuite "difference" $ \sourcePos children -> do r :: ℝ <- argument "r" `defaultTo` 0 `doc` "Radius of rounding for the difference interface" - pure $ pure $ if r > 0 - then objReduce (unsafeUncurry (Prim.differenceR r)) (unsafeUncurry (Prim.differenceR r)) children - else objReduce (unsafeUncurry Prim.difference) (unsafeUncurry Prim.difference) children - where - unsafeUncurry :: (a -> [a] -> c) -> [a] -> c - unsafeUncurry f = uncurry f . unsafeUncons - - unsafeUncons :: [a] -> (a, [a]) - unsafeUncons (a : as) = (a, as) - -- NOTE: This error is guarded against during the @null children@ check in the function body. - unsafeUncons _ = error "difference requires at least one element; zero given" - + pure $ do + if (null children) + then do + errorC sourcePos "difference requires at least one element; none given." + pure [] + else pure $ if r > 0 + then objReduce (unsafeUncurry (Prim.differenceR r)) (unsafeUncurry (Prim.differenceR r)) children + else objReduce (unsafeUncurry Prim.difference) (unsafeUncurry Prim.difference) children + where + unsafeUncons :: [a] -> Maybe (a, [a]) + unsafeUncons (a : as) = Just (a, as) + -- NOTE: This error is guarded against during the @null children@ check in the function body. + unsafeUncons _ = Nothing + -- This error should not be reachable. + unsafeUncurry :: (a -> [a] -> c) -> [a] -> c + unsafeUncurry f = uncurry f . fromMaybe (error "Impossible error: difference requires at least one element; zero given") . unsafeUncons translate :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) translate = moduleWithSuite "translate" $ \_ children -> do example "translate ([2,3]) circle (4);" @@ -690,7 +808,7 @@ multmatrix = moduleWithSuite "multmatrix" $ \_ children -> do moduleWithSuite :: Text -> (SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -> (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) moduleWithSuite name modArgMapper = (Symbol name, modArgMapper) -moduleWithoutSuite :: Text -> (SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -> (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) +moduleWithoutSuite :: Text -> (SourcePosition -> ArgParser (StateC [OVal])) -> (Symbol, SourcePosition -> ArgParser (StateC [OVal])) moduleWithoutSuite name modArgMapper = (Symbol name, modArgMapper) addObj2 :: SymbolicObj2 -> ArgParser (StateC [OVal]) diff --git a/Graphics/Implicit/ExtOpenScad/Util/OVal.hs b/Graphics/Implicit/ExtOpenScad/Util/OVal.hs index 657670d5..2f42dadb 100644 --- a/Graphics/Implicit/ExtOpenScad/Util/OVal.hs +++ b/Graphics/Implicit/ExtOpenScad/Util/OVal.hs @@ -18,7 +18,7 @@ import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left,Right), (==) import Graphics.Implicit.Definitions(V2, ℝ, ℝ2, ℕ, SymbolicObj2, SymbolicObj3, ExtrudeMScale(C1, C2, Fn), fromℕtoℝ) -import Graphics.Implicit.ExtOpenScad.Definitions (OVal(ONum, OBool, OString, OList, OFunc, OUndefined, OUModule, ONModule, OVargsModule, OError, OObj2, OObj3, OIO)) +import Graphics.Implicit.ExtOpenScad.Definitions (OVal(ONum, OBool, OString, OList, OFunc, OUndefined, OUModule, ONModule, ONModuleWithSuite, OVargsModule, OError, OObj2, OObj3, OIO)) import Control.Monad (msum) @@ -160,19 +160,20 @@ instance OTypeMirror ExtrudeMScale where -- A string representing each type. oTypeStr :: OVal -> Text -oTypeStr OUndefined = "Undefined" -oTypeStr (OBool _ ) = "Bool" -oTypeStr (ONum _ ) = "Number" -oTypeStr (OList _ ) = "List" -oTypeStr (OString _ ) = "String" -oTypeStr (OFunc _ ) = "Function" -oTypeStr (OIO _ ) = "IO" -oTypeStr (OUModule {} ) = "User Defined Module" -oTypeStr (ONModule {} ) = "Built-in Module" -oTypeStr (OVargsModule _ _ ) = "VargsModule" -oTypeStr (OError _ ) = "Error" -oTypeStr (OObj2 _ ) = "2D Object" -oTypeStr (OObj3 _ ) = "3D Object" +oTypeStr OUndefined = "Undefined" +oTypeStr (OBool _ ) = "Bool" +oTypeStr (ONum _ ) = "Number" +oTypeStr (OList _ ) = "List" +oTypeStr (OString _ ) = "String" +oTypeStr (OFunc _ ) = "Function" +oTypeStr (OIO _ ) = "IO" +oTypeStr (OUModule {} ) = "User Defined Module" +oTypeStr (ONModuleWithSuite {}) = "Built-in Module with suite" +oTypeStr (ONModule {} ) = "Built-in Module" +oTypeStr (OVargsModule _ _ ) = "VargsModule" +oTypeStr (OError _ ) = "Error" +oTypeStr (OObj2 _ ) = "2D Object" +oTypeStr (OObj3 _ ) = "3D Object" getErrors :: OVal -> Maybe Text getErrors (OError er) = Just er diff --git a/Graphics/Implicit/ObjectUtil/GetBox3.hs b/Graphics/Implicit/ObjectUtil/GetBox3.hs index d2604dad..92a7a06b 100644 --- a/Graphics/Implicit/ObjectUtil/GetBox3.hs +++ b/Graphics/Implicit/ObjectUtil/GetBox3.hs @@ -7,13 +7,23 @@ module Graphics.Implicit.ObjectUtil.GetBox3 (getBox3) where import Prelude(uncurry, pure, Bool(False), Either (Left, Right), (==), max, (/), (-), (+), fmap, unzip, ($), (<$>), (.), minimum, maximum, min, (>), (*), (<), abs, either, const, otherwise, take, fst, snd) +-- For Maybe types. +import Data.Maybe (fromMaybe, Maybe(Just, Nothing)) + +import Data.Foldable (foldl') + +import Linear (V2(V2), V3(V3)) +import qualified Linear (rotate, point, normalizePoint, (!*)) + import Graphics.Implicit.Definitions ( Fastℕ, fromFastℕ, ExtrudeMScale(C2, C1), - SymbolicObj3(Shared3, Cube, Sphere, Cylinder, Rotate3, Transform3, Extrude, ExtrudeOnEdgeOf, ExtrudeM, RotateExtrude, Torus, Ellipsoid, BoxFrame, Link), + SymbolicObj3(Shared3, Cube, Sphere, Cylinder, Polyhedron, Rotate3, Transform3, Extrude, ExtrudeOnEdgeOf, ExtrudeM, RotateExtrude, Torus, Ellipsoid, BoxFrame, Link), Box3, ℝ, + ℝ2, + ℝ3, fromFastℕtoℝ, toScaleFn ) @@ -21,9 +31,6 @@ import Graphics.Implicit.ObjectUtil.GetBox2 (getBox2, getBox2R) import Graphics.Implicit.ObjectUtil.GetBoxShared (corners, pointsBox, getBoxShared) -import Linear (V2(V2), V3(V3)) -import qualified Linear - -- FIXME: many variables are being ignored here. no rounding for intersect, or difference.. etc. -- Get a Box3 around the given object. @@ -33,6 +40,15 @@ getBox3 (Shared3 obj) = getBoxShared obj getBox3 (Cube size) = (pure 0, size) getBox3 (Sphere r) = (pure (-r), pure r) getBox3 (Cylinder h r1 r2) = (V3 (-r) (-r) 0, V3 r r h ) where r = max r1 r2 +getBox3 (Polyhedron points _) = (minimum_point, maximum_point) + where + (minimum_point, maximum_point) = fromMaybe (V3 0 0 0, V3 0 0 0) maybeVs + maybeVs :: (Maybe (ℝ3,ℝ3)) + maybeVs = foldl' findMinMax Nothing points + where + findMinMax :: (Maybe (ℝ3,ℝ3)) -> ℝ3 -> (Maybe (ℝ3,ℝ3)) + findMinMax Nothing newV3 = Just (newV3, newV3) + findMinMax (Just (V3 minx miny minz,V3 maxx maxy maxz)) (V3 newx newy newz) = Just (V3 (min minx newx) (min miny newy) (min minz newz), V3 (max maxx newx) (max maxy newy) (max maxz newz)) getBox3 (Torus r1 r2) = let r = r1 + r2 in (V3 (-r) (-r) (-r2), V3 r r r2) @@ -105,9 +121,9 @@ getBox3 (ExtrudeM twist scale translate symbObj height) = (tminx, tmaxx, tminy, tmaxy) = let - tvalsx :: (ℝ -> V2 ℝ) -> [ℝ] + tvalsx :: (ℝ -> ℝ2) -> [ℝ] tvalsx tfun = fmap (fst . unpack . tfun) hrange - tvalsy :: (ℝ -> V2 ℝ) -> [ℝ] + tvalsy :: (ℝ -> ℝ2) -> [ℝ] tvalsy tfun = fmap (snd . unpack . tfun) hrange in case translate of Left (V2 tvalx tvaly) -> (tvalx, tvalx, tvaly, tvaly) diff --git a/Graphics/Implicit/ObjectUtil/GetImplicit3.hs b/Graphics/Implicit/ObjectUtil/GetImplicit3.hs index db239303..114575a9 100644 --- a/Graphics/Implicit/ObjectUtil/GetImplicit3.hs +++ b/Graphics/Implicit/ObjectUtil/GetImplicit3.hs @@ -1,17 +1,30 @@ --- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com) --- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com) -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com) +-- Copyright 2014 2015 2016, Julia Longtin (julia.longtin@gmail.com) -- Released under the GNU AGPLV3+, see LICENSE module Graphics.Implicit.ObjectUtil.GetImplicit3 (getImplicit3) where -import Prelude (id, (||), (/=), either, round, fromInteger, Either(Left, Right), abs, (-), (/), (*), sqrt, (+), atan2, max, cos, minimum, ($), sin, pi, (.), Bool(True, False), ceiling, floor, pure, (==), otherwise, (**), min, Num, Applicative) +-- Import only what we need from the prelude. +import Prelude (abs, atan2, cos, ceiling, either, error, floor, fromInteger, id, max, min, minimum, negate, otherwise, pi, pure, round, sin, sqrt, (||), (/=), Either(Left, Right), (-), (/), (*), (+), ($), (.), Bool(True, False), (==), (**), Num, Applicative, (<$>)) + +import Control.Lens ((^.)) + +import Data.List (minimumBy) + +import Data.Ord (compare) + +import Linear (V2(V2), V3(V3), _xy, _z, distance) +import qualified Linear (conjugate, inv44, normalizePoint, point, rotate, Metric) + +-- Matrix times column vector. +import Linear.Matrix ((!*)) import Graphics.Implicit.Definitions ( objectRounding, ObjectContext, ℕ, - SymbolicObj3(Cube, Sphere, Cylinder, Rotate3, Transform3, Extrude, + SymbolicObj3(Cube, Sphere, Cylinder, Polyhedron, Rotate3, Transform3, Extrude, ExtrudeM, ExtrudeOnEdgeOf, RotateExtrude, Shared3, Torus, Ellipsoid, BoxFrame, Link), Obj3, ℝ2, @@ -20,23 +33,20 @@ import Graphics.Implicit.Definitions toScaleFn, ℝ3 ) -import Graphics.Implicit.MathUtil ( rmax, rmaximum ) +-- For handling extrusion of 2D shapes to 3D. +import {-# SOURCE #-} Graphics.Implicit.Primitives (getImplicit) -import qualified Data.Either as Either (either) +import Graphics.Implicit.TriUtil (distancePointToTriangle, findTriangle, pointOnOutsideByWinding) --- Use getImplicit for handling extrusion of 2D shapes to 3D. -import Graphics.Implicit.ObjectUtil.GetImplicitShared (getImplicitShared) -import Linear (V2(V2), V3(V3), _xy, _z) -import qualified Linear +import Graphics.Implicit.MathUtil (rmax, rmaximum) -import {-# SOURCE #-} Graphics.Implicit.Primitives (getImplicit) -import Control.Lens ((^.)) +import Graphics.Implicit.ObjectUtil.GetImplicitShared (getImplicitShared) default (ℝ) -- Length similar to the opengl version, needed for some of the shape definitions openglLength :: (Linear.Metric f, Num (f ℝ), Applicative f) => f ℝ -> ℝ -openglLength v = Linear.distance (abs v) $ pure 0 +openglLength v = distance (abs v) $ pure 0 -- Component wise maximum. This is what the opengl language is doing, so we need -- it for the function as defined by the blog above. @@ -59,6 +69,22 @@ getImplicit3 _ (Cylinder h r1 r2) = \(V3 x y z) -> θ = atan2 (r2-r1) h in max (d * cos θ) (abs (z-h/2) - (h/2)) +-- FIXME: Make Polyhedron correct by construction. +getImplicit3 _ (Polyhedron [] _) = error "Asked to find distance to an empty polyhedron. No points given." +getImplicit3 _ (Polyhedron _ []) = error "Asked to find distance to an empty polyhedron. No faces given." +getImplicit3 _ (Polyhedron points tris) = \(point) -> + let + ((_,res), _) = unsignedDistanceAndTriangleClosestTo point + in +-- if pointOnOutside point (findTriangle points closestTri) closestTri feature + if pointOnOutsideByWinding point triangles + then res + else negate $ res + where + unsignedDistanceAndTriangleClosestTo point = minimumBy (\((_,a),_) ((_,b),_) -> a `compare` b) $ featDistTriangles point + featDistTriangles point = (\triangle -> (distancePointToTriangle point triangle, triangle)) <$> triangles + -- Decompose our tris into triangles. + triangles = findTriangle points <$> tris getImplicit3 _ (BoxFrame b e) = \p' -> let p@(V3 px py pz) = abs p' - b V3 qx qy qz = abs (p + pure e) - pure e @@ -77,7 +103,7 @@ getImplicit3 _ (Link le r1 r2) = \(V3 px py pz) -> getImplicit3 ctx (Rotate3 q symbObj) = getImplicit3 ctx symbObj . Linear.rotate (Linear.conjugate q) getImplicit3 ctx (Transform3 m symbObj) = - getImplicit3 ctx symbObj . Linear.normalizePoint . (Linear.inv44 m Linear.!*) . Linear.point + getImplicit3 ctx symbObj . Linear.normalizePoint . (Linear.inv44 m !*) . Linear.point -- 2D Based getImplicit3 ctx (Extrude h symbObj) = let @@ -147,12 +173,12 @@ getImplicit3 ctx (RotateExtrude totalRotation translate rotate symbObj) = || either is360m (\f -> is360m (f 0 - f totalRotation)) rotate round' = objectRounding ctx translate' :: ℝ -> ℝ2 - translate' = Either.either + translate' = either (\(V2 a b) θ -> V2 (a*θ/totalRotation) (b*θ/totalRotation)) id translate rotate' :: ℝ -> ℝ - rotate' = Either.either + rotate' = either (\t θ -> t*θ/totalRotation ) id rotate @@ -173,9 +199,9 @@ getImplicit3 ctx (RotateExtrude totalRotation translate rotate symbObj) = [0 .. floor $ (totalRotation - θ) / tau] n <- ns let - θvirt = fromℕtoℝ n * tau + θ - (V2 rshift zshift) = translate' θvirt - twist = rotate' θvirt + θvert = fromℕtoℝ n * tau + θ + (V2 rshift zshift) = translate' θvert + twist = rotate' θvert rz_pos = if twists then let (c,s) = (cos twist, sin twist) @@ -186,7 +212,8 @@ getImplicit3 ctx (RotateExtrude totalRotation translate rotate symbObj) = pure $ if capped then rmax round' - (abs (θvirt - (totalRotation / 2)) - (totalRotation / 2)) + (abs (θvert - (totalRotation / 2)) - (totalRotation / 2)) (obj rz_pos) else obj rz_pos getImplicit3 ctx (Shared3 obj) = getImplicitShared ctx obj + diff --git a/Graphics/Implicit/Primitives.hs b/Graphics/Implicit/Primitives.hs index 9d73f161..8bdaaf28 100644 --- a/Graphics/Implicit/Primitives.hs +++ b/Graphics/Implicit/Primitives.hs @@ -36,6 +36,7 @@ module Graphics.Implicit.Primitives ( ellipsoid, square, rect, polygon, + polyhedron, rotateExtrude, rotate3, rotateQ, @@ -58,7 +59,7 @@ module Graphics.Implicit.Primitives ( import Prelude(Applicative, Eq, Foldable, Num, abs, (<), otherwise, Num, (-), (*), (/), (.), negate, Bool(True, False), Maybe(Just, Nothing), Either, fmap, ($), (<=), (&&), max, Ord) import Graphics.Implicit.Canon (canonicalize2, canonicalize3) -import Graphics.Implicit.Definitions (ObjectContext, ℝ, ℝ2, ℝ3, Box2, +import Graphics.Implicit.Definitions (ObjectContext, ℝ, ℝ2, ℝ3, ℕ, Box2, SharedObj(Empty, Full, Translate, @@ -87,6 +88,7 @@ import Graphics.Implicit.Definitions (ObjectContext, ℝ, ℝ2, ℝ3, Box2, Cube, Sphere, Cylinder, + Polyhedron, Torus, BoxFrame, Rotate3, @@ -131,9 +133,16 @@ cube cube False size = Cube size cube True size = translate (fmap (negate . (/ 2)) size) $ Cube size +-- | A polyhedron +polyhedron + :: [ℝ3] -- ^ Points + -> [(ℕ,ℕ,ℕ)] -- ^ triangles, resolved through indexing Points + -> SymbolicObj3 -- ^ Resulting polyhedron +polyhedron = Polyhedron + -- | A conical frustum --- ie. a cylinder with different radii at either end. -cylinder2 :: - ℝ -- ^ Radius of the cylinder +cylinder2 + :: ℝ -- ^ Radius of the cylinder -> ℝ -- ^ Second radius of the cylinder -> ℝ -- ^ Height of the cylinder -> SymbolicObj3 -- ^ Resulting cylinder diff --git a/Graphics/Implicit/TriUtil.hs b/Graphics/Implicit/TriUtil.hs new file mode 100644 index 00000000..cd80fc0d --- /dev/null +++ b/Graphics/Implicit/TriUtil.hs @@ -0,0 +1,200 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com) +-- Copyright 2014-2026, Julia Longtin (julia.longtin@gmail.com) +-- Released under the GNU AGPLV3+, see LICENSE + +-- You see, what I thought I'd do is put a raytracer inside of a raytracer... what could go wrong... +-- With inspiration from: https://github.com/RenderKit/embree/blob/master/tutorials/common/math/closest_point.h + +module Graphics.Implicit.TriUtil ( + angleAt, + closestFeatureToTriangle, + distancePointToTriangle, + findTriangle, + normOfTriangle, + pointOnOutsideByWinding, + ClosestFeature(FeatFace, + FeatVertex1, FeatVertex2, FeatVertex3, + FeatEdge12, FeatEdge13, FeatEdge23), + Tri, + Triangle + ) where + +import Prelude (abs, acos, atan2, error, length, max, min, otherwise, pi, show, sum, toInteger, (<$>), (>), (<), (&&), (<=), (>=),($), (.), (/), (+), (-), (*), (==), (||), (<>), Bool, Eq) + +import Graphics.Implicit.Definitions ( + fromℕ, + ℝ, + ℝ3, + ℕ) + +import Data.List (genericIndex) + +import Linear (dot, distance, norm) +import qualified Linear (normalize) + +-- The cross product. +import Linear.V3 (cross) + +-- Matrix times scalar. +import Linear.Vector ((*^)) + +type Tri = (ℕ,ℕ,ℕ) + +type Triangle = (ℝ3, ℝ3, ℝ3) + +-- The closest part of a triangle to a point. +data ClosestFeature = FeatVertex1 | FeatVertex2 | FeatVertex3 | FeatEdge12 | FeatEdge13 | FeatEdge23 | FeatFace + deriving Eq + +-- FIXME: Make these indices correct by construction? +-- | Reconstitute a Triangle from a Tri, and our points array. +findTriangle :: [ℝ3] -> Tri -> Triangle +findTriangle vertices (i1,i2,i3) + | outOfRange i1 = error $ "bad vertex index(out of range): " <> show i1 <> "\n" + | outOfRange i2 = error $ "bad vertex index(out of range): " <> show i2 <> "\n" + | outOfRange i3 = error $ "bad vertex index(out of range): " <> show i3 <> "\n" + -- FIXME: there are many more degenerate forms of polyhedron possible here. move polyhedron to only holding a mesh? + | otherwise = (genericIndex vertices i1, genericIndex vertices i2, genericIndex vertices i3) + where + -- FIXME: >=BASE-4.21: replace this with compareLength once debian stable ships 4.21. + outOfRange :: ℕ -> Bool + outOfRange v = v < 0 || toInteger (length vertices) <= fromℕ v + +-- | Find the normal of a given Triangle +normOfTriangle :: Triangle -> ℝ3 +normOfTriangle (v1,v2,v3) = Linear.normalize $ (v2-v1) `cross` (v3-v1) + +-- | Determine if the point is on the outside of the object. +-- Note: We cannot terminate early.. because all of the triangles must be counted. +pointOnOutsideByWinding :: ℝ3 -> [Triangle] -> Bool +pointOnOutsideByWinding point triangles = abs res < pi + where + res = sum $ halfSolidAngleOfTriangle point <$> triangles + +-- Find half of the signed solid angle of a given Triangle as seen from point. +-- A solid angle measures how much of the field of view this triangle covers. think: arcs in astronomy. +halfSolidAngleOfTriangle :: ℝ3 -> Triangle -> ℝ +halfSolidAngleOfTriangle point (v1,v2,v3) + | normv1p <= eps || normv2p <= eps || normv3p <= eps = 0 + | otherwise = atan2 numerator denominator + where + eps :: ℝ + eps = 1e-14 + v1p = v1 - point + v2p = v2 - point + v3p = v3 - point + -- length of v1p, v2p, v3p + normv1p = norm v1p + normv2p = norm v2p + normv3p = norm v3p + -- The Van Oosterom-Strackee Algorithm. + numerator = v1p `dot` (v2p `cross` v3p) + denominator = normv1p * normv2p * normv3p + + (v1p `dot` v2p) * normv3p + + (v2p `dot` v3p) * normv1p + + (v3p `dot` v1p) * normv2p + +-- find the angle of the corner of the triangle containing a given vertex. +angleAt :: ℝ3 -> Triangle -> ℝ +angleAt vertex (v1,v2,v3) + | vertex == v1 = acos $ clamp $ Linear.normalize (v2-v1) `dot` Linear.normalize (v3-v1) + | vertex == v2 = acos $ clamp $ Linear.normalize (v1-v2) `dot` Linear.normalize (v3-v2) + | vertex == v3 = acos $ clamp $ Linear.normalize (v1-v3) `dot` Linear.normalize (v2-v3) + | otherwise = error $ "tried to get angleAt with a point not one of the vertexes: " <> show vertex <> "\n" + where + clamp :: ℝ -> ℝ + clamp = max (-1) . min 1 + +distancePointToTriangle :: ℝ3 -> Triangle -> (ClosestFeature, ℝ) +distancePointToTriangle point (vertex1, vertex2, vertex3) = (adjustedFeature, distance point pointOnFeature) + where + (resFeature, pointOnFeature) = closestFeatureToTriangleCentered adjustedTriangle point + -- First math precision transform: change which adressing system we use for the triangle, ensuring the far side is 'away' from the virtex we address from. + adjustedFeature + | adjustedTriangle == (vertex3, vertex1, vertex2) = + case resFeature of + FeatVertex1 -> FeatVertex3 + FeatVertex2 -> FeatVertex1 + FeatVertex3 -> FeatVertex2 + FeatEdge12 -> FeatEdge13 + FeatEdge13 -> FeatEdge23 + FeatEdge23 -> FeatEdge12 + FeatFace -> FeatFace + | adjustedTriangle == (vertex2, vertex3, vertex1) = + case resFeature of + FeatVertex1 -> FeatVertex2 + FeatVertex2 -> FeatVertex3 + FeatVertex3 -> FeatVertex1 + FeatEdge12 -> FeatEdge23 + FeatEdge13 -> FeatEdge12 + FeatEdge23 -> FeatEdge13 + FeatFace -> FeatFace + | otherwise = resFeature + adjustedTriangle + | abLength >= bcLength && abLength >= caLength = (vertex3, vertex1, vertex2) + | abLength >= caLength = (vertex1, vertex2, vertex3) + | otherwise = (vertex2, vertex3, vertex1) + where + -- Really, using length-squared. don't have to abs it, don't have to sqrt it. + abLength = (vertex2-vertex1) `dot` (vertex2-vertex1) + bcLength = (vertex3-vertex2) `dot` (vertex3-vertex2) + caLength = (vertex1-vertex3) `dot` (vertex1-vertex3) + -- Second math precision transform: Force closestFeatureToTriangle to work near the origin by translating our query, and then translating the response. + closestFeatureToTriangleCentered :: Triangle -> ℝ3 -> (ClosestFeature, ℝ3) + closestFeatureToTriangleCentered (ver1, ver2, ver3) inpoint = (feature, originDistance + res) + where + (feature, res) = closestFeatureToTriangle translatedTriangle translatedPoint + translatedTriangle = (ver1 - originDistance, ver2 - originDistance, ver3 - originDistance) + translatedPoint = inpoint - originDistance + originDistance = 1/3 *^ (ver1 + ver2 + ver3) + +-- | Find the closest part of a triangle (edge, center, vertex) to a given point , along with the point on the closest part that is closest to the given point. +closestFeatureToTriangle :: Triangle -> ℝ3 -> (ClosestFeature, ℝ3) +closestFeatureToTriangle (v1, v2, v3) p + -- Closest to the vertices + | d1 <= 0 && d2 <= 0 = (FeatVertex1, v1) + | d3 >= 0 && d4 <= d3 = (FeatVertex2, v2) + | d6 >= 0 && d5 <= d6 = (FeatVertex3, v3) + -- Nearest to the edges + | va <= 0 && d1 > 0 && d3 <= 0 = (FeatEdge12, v1 + (d1 / (d1 - d3)) *^ vec12) + | vb <= 0 && d2 > 0 && d6 <= 0 = (FeatEdge13, v1 + (d2 / (d2 - d6)) *^ vec13) + | vc <= 0 && dx > 0 && dy > 0 = (FeatEdge23, v2 + (dx / (dx + dy)) *^ vec23) + -- Exactly on an edge, don't bother dividing by zero, please. + | denom == 0 = (FeatFace, p) + -- On the triangle's surface + | otherwise = (FeatFace, v1 + v *^ vec12 + w *^ vec13) + where + -- The distance along edge12 and edge23, for segment V1 -> P when translated onto the triangle's plane. + -- (P when translaned? Read: a line is drawn down to the plane the triangle is on, from p, to a point that is at a right angle with said line.) + d1 = vec12 `dot` vec1p + d2 = vec13 `dot` vec1p + -- Our edge vectors. We have picked v1 to address the space by, for convenience. + vec12 = v2 - v1 + vec13 = v3 - v1 + -- A segment between our point, and chosen vertex. + vec1p = p - v1 + -- Distance along edge12 and edge23, for segment V2 -> P when translated onto the triangle's plane. + d3 = vec12 `dot` vec2p + d4 = vec13 `dot` vec2p + -- A segment between our point, and the second vertex. + vec2p = p - v2 + -- Distance along edge12 and edge23, for segment V3 -> P when translated onto the triangle's plane. + d5 = vec12 `dot` vec3p + d6 = vec13 `dot` vec3p + -- A segment between our point, and the third vertex. + vec3p = p - v3 + -- An edge vector, along edge23. + vec23 = v3 - v2 + -- The fractional denenominators. + va = d1 * d4 - d3 * d2 + vb = d2 * d5 - d6 * d1 + vc = d3 * d6 - d5 * d4 + -- Two convienience values, to make the spacing on the formulas above work. + dx = d4 - d3 + dy = d5 - d6 + -- The denominator. + denom = va + vb + vc + -- barycentric results, where we actually intersect. + v = vb / denom + w = va / denom diff --git a/Makefile b/Makefile index 3e1b8864..e10ac901 100644 --- a/Makefile +++ b/Makefile @@ -152,7 +152,7 @@ dist: $(TARGETS) # Generate examples. examples: $(EXTOPENSCADBIN) - cd Examples && for each in `find ./ -name '*scad' -type f | sort`; do { echo $$each ; ../$(EXTOPENSCADBIN) $(SCADOPTS) $$each $(RTSOPTS); } done + cd Examples && for each in `find ./ -name '*scad' -type f | sort`; do { echo ../$(EXTOPENSCADBIN) $(SCADOPTS) $$each $(RTSOPTS); ../$(EXTOPENSCADBIN) $(SCADOPTS) $$each $(RTSOPTS); } done # NOTE: on debian, if this fails to find the linear package, run: 'apt install libghc-linear-dev libghc-show-combinators-dev libghc-blaze-svg-dev libghc-data-default-dev libghc-juicypixels-dev' cd Examples && for each in `find ./ -name '*.hs' -type f | sort`; do { filename=$(basename "$$each"); filename="$${filename%.*}"; cd ..; $(GHC) $(EXAMPLEOPTS) Examples/$$filename.hs -o Examples/$$filename; cd Examples; echo $$filename; $$filename +RTS -t ; } done diff --git a/implicit.cabal b/implicit.cabal index 49f403fd..069fa03b 100644 --- a/implicit.cabal +++ b/implicit.cabal @@ -53,6 +53,8 @@ Common binstuff -threaded -rtsopts "-with-rtsopts -N -qg -t" -optc-O3 + -- Call the heap checker, even when memory is not being allocated. needed for control-c to work right when debugging. + -- -fno-omit-yields -- see GHC manual 8.2.1 section 6.5.1. -feager-blackholing -Wall @@ -73,6 +75,8 @@ Common libstuff Default-extensions: NoImplicitPrelude Ghc-options: -optc-O3 + -- Call the heap checker, even when memory is not being allocated. needed for control-c to work right when debugging. + -- -fno-omit-yields -- see GHC manual 8.2.1 section 6.5.1. -feager-blackholing -Wall @@ -145,6 +149,7 @@ Library Graphics.Implicit.Export.Resolution Other-modules: Graphics.Implicit.FastIntUtil + Graphics.Implicit.TriUtil Graphics.Implicit.IntegralUtil Graphics.Implicit.ObjectUtil.GetBox2 Graphics.Implicit.ObjectUtil.GetBox3 diff --git a/programs/docgen.hs b/programs/docgen.hs index 4f244422..8eefca75 100644 --- a/programs/docgen.hs +++ b/programs/docgen.hs @@ -6,7 +6,7 @@ import Prelude(IO, Show, String, Int, Maybe(Just,Nothing), Eq, return, ($), show, fmap, (<>), putStrLn, filter, zip, null, undefined, const, Bool(True,False), fst, (.), head, length, (/=), (+), error, print, drop) import Graphics.Implicit.ExtOpenScad.Primitives (primitiveModules) -import Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP,APFail,APExample,APTest,APTerminator,APBranch), Symbol(Symbol), OVal(ONModule), SourcePosition(SourcePosition), StateC) +import Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP,APFail,APExample,APTest,APTerminator,APBranch), Symbol(Symbol), OVal(ONModule, ONModuleWithSuite), SourcePosition(SourcePosition), StateC) import qualified Control.Exception as Ex (catch, SomeException) import Control.Monad (forM_) @@ -114,9 +114,10 @@ main = do dumpPrimitive moduleName moduleDocList 0 where getArgParserFrom :: (Symbol, OVal) -> ArgParser(StateC [OVal]) - getArgParserFrom (_, ONModule _ implementation _) = implementation sourcePosition [] - where sourcePosition = SourcePosition 0 0 "docgen" + getArgParserFrom (_, ONModule _ implementation _) = implementation sourcePosition + getArgParserFrom (_, ONModuleWithSuite _ implementation _) = implementation sourcePosition [] getArgParserFrom (_, _) = error "bad value in primitive array." + sourcePosition = SourcePosition 0 0 "docgen" -- | the format we extract documentation into data Doc = Doc String [DocPart] diff --git a/tests/Graphics/Implicit/Test/Instances.hs b/tests/Graphics/Implicit/Test/Instances.hs index 87ece632..d55628e5 100644 --- a/tests/Graphics/Implicit/Test/Instances.hs +++ b/tests/Graphics/Implicit/Test/Instances.hs @@ -20,7 +20,7 @@ module Graphics.Implicit.Test.Instances (Observe, observe, (=~=), arbitraryNonZeroV) where -import Prelude (Applicative, (.), not, abs, fmap, Bool(False, True), Bounded, Double, Integer, fromIntegral, (*), (/), (^), round, Enum, Show(show), unlines, Ord, compare, Eq, (==), pure, RealFloat(isNaN), Int, Double, ($), (<), div, (<*>), (<$>), (+), (<>), (<=)) +import Prelude (Applicative, (.), not, return, abs, fmap, Bool(False, True), Bounded, Double, Integer, fromIntegral, (*), (/), (^), round, Enum, Show(show), unlines, Ord, compare, Eq, (==), pure, RealFloat(isNaN), Int, Double, ($), (<), div, (<*>), (<$>), (+), (<>), (<=)) #if MIN_VERSION_base(4,17,0) import Prelude (type(~)) #endif @@ -50,6 +50,7 @@ import Graphics.Implicit.Definitions ℝ, ℝ2, ℝ3, + ℕ, SharedObj(Outset, Translate, Scale, UnionR, IntersectR, DifferenceR, Shell, WithRounding) ) @@ -215,6 +216,12 @@ instance Arbitrary (Quaternion ℝ) where then discard else pure $ axisAngle v q +instance Arbitrary ℕ where +-- shrink = genericShrink + arbitrary = do + n <- getPositive <$> arbitrary + return n + ------------------------------------------------------------------------------ -- Minimum of quickspec(s) Observe class and instances required for implicit testsuite -- BSD3 Copyright: 2009-2019 Nick Smallbone