mirror of
https://github.com/Haskell-Things/ImplicitCAD.git
synced 2024-09-17 16:08:01 +03:00
more applicative coding style.
This commit is contained in:
parent
8528cc416f
commit
6c1e0565bc
@ -12,11 +12,11 @@ object2 = squarePipe (10,10,10) 1 100
|
|||||||
squarePipe :: ℝ3 -> ℝ -> ℝ -> SymbolicObj3
|
squarePipe :: ℝ3 -> ℝ -> ℝ -> SymbolicObj3
|
||||||
squarePipe (x,y,z) diameter precision =
|
squarePipe (x,y,z) diameter precision =
|
||||||
union
|
union
|
||||||
$ ((\start-> translate start
|
((\start-> translate start
|
||||||
$ rect3R 0 (0,0,0) (diameter,diameter,diameter)
|
$ rect3R 0 (0,0,0) (diameter,diameter,diameter)
|
||||||
)
|
)
|
||||||
<$>
|
<$>
|
||||||
zip3 (fmap (\n->(fromIntegral n/precision)*x) [0..100])
|
zip3 (fmap (\n->(fromIntegral n/precision)*x) [0..100])
|
||||||
(fmap (\n->(fromIntegral n/precision)*y) [0..100])
|
(fmap (\n->(fromIntegral n/precision)*y) [0..100])
|
||||||
(fmap (\n->(fromIntegral n/precision)*z) [0..100]))
|
(fmap (\n->(fromIntegral n/precision)*z) [0..100]))
|
||||||
|
|
||||||
|
@ -96,7 +96,7 @@ dxf2 plines = toLazyText $ dxf2Header <> dxf2Tables <> dxf2Blocks <> dxf2Entitie
|
|||||||
" 8\n" <> "0\n" <>
|
" 8\n" <> "0\n" <>
|
||||||
" 6\n" <> "CONTINUOUS\n" <>
|
" 6\n" <> "CONTINUOUS\n" <>
|
||||||
" 66\n" <> "1\n" <>
|
" 66\n" <> "1\n" <>
|
||||||
" 62\n" <> (buildInt $ length singlePolyline) <> "\n" <>
|
" 62\n" <> buildInt (length singlePolyline) <> "\n" <>
|
||||||
" 10\n" <> "0.0\n" <>
|
" 10\n" <> "0.0\n" <>
|
||||||
" 20\n" <> "0.0\n" <>
|
" 20\n" <> "0.0\n" <>
|
||||||
" 30\n" <> "0.0000\n" <>
|
" 30\n" <> "0.0000\n" <>
|
||||||
|
@ -8,7 +8,7 @@
|
|||||||
-- export getContour and getMesh, which returns the edge of a 2D object, or the surface of a 3D object, respectively.
|
-- export getContour and getMesh, which returns the edge of a 2D object, or the surface of a 3D object, respectively.
|
||||||
module Graphics.Implicit.Export.Render (getMesh, getContour) where
|
module Graphics.Implicit.Export.Render (getMesh, getContour) where
|
||||||
|
|
||||||
import Prelude(ceiling, ($), (+), (*), max, div, tail, fmap, reverse, (.), foldMap, min, Int, (<>))
|
import Prelude(ceiling, ($), (+), (*), max, div, tail, fmap, reverse, (.), foldMap, min, Int, (<>), (<$>))
|
||||||
|
|
||||||
import Graphics.Implicit.Definitions (ℝ, ℕ, Fastℕ, ℝ2, ℝ3, TriangleMesh, Obj2, Obj3, Polyline(Polyline), (⋯/), both, allthree, fromℕtoℝ, fromℕ)
|
import Graphics.Implicit.Definitions (ℝ, ℕ, Fastℕ, ℝ2, ℝ3, TriangleMesh, Obj2, Obj3, Polyline(Polyline), (⋯/), both, allthree, fromℕtoℝ, fromℕ)
|
||||||
|
|
||||||
@ -129,21 +129,21 @@ getMesh p1@(x1,y1,z1) p2 res@(xres,yres,zres) obj =
|
|||||||
|
|
||||||
-- (2) Calculate segments for each side
|
-- (2) Calculate segments for each side
|
||||||
segsZ = [[[
|
segsZ = [[[
|
||||||
fmap (injZ z0) $ getSegs (x0,y0) (x1',y1') (obj **$ z0) (objX0Y0Z0, objX1Y0Z0, objX0Y1Z0, objX1Y1Z0) (midA0, midA1, midB0, midB1)
|
injZ z0 <$> getSegs (x0,y0) (x1',y1') (obj **$ z0) (objX0Y0Z0, objX1Y0Z0, objX0Y1Z0, objX1Y1Z0) (midA0, midA1, midB0, midB1)
|
||||||
| x0<-pXs | x1'<-tail pXs |midB0<-mX'' | midB1<-mX'T | midA0<-mY'' | midA1<-tail mY'' | objX0Y0Z0<-objY0Z0 | objX1Y0Z0<- tail objY0Z0 | objX0Y1Z0<-objY1Z0 | objX1Y1Z0<-tail objY1Z0
|
| x0<-pXs | x1'<-tail pXs |midB0<-mX'' | midB1<-mX'T | midA0<-mY'' | midA1<-tail mY'' | objX0Y0Z0<-objY0Z0 | objX1Y0Z0<- tail objY0Z0 | objX0Y1Z0<-objY1Z0 | objX1Y1Z0<-tail objY1Z0
|
||||||
]| y0<-pYs | y1'<-tail pYs |mX'' <-mX' | mX'T <-tail mX' | mY'' <-mY' | objY0Z0 <-objZ0 | objY1Z0 <-tail objZ0
|
]| y0<-pYs | y1'<-tail pYs |mX'' <-mX' | mX'T <-tail mX' | mY'' <-mY' | objY0Z0 <-objZ0 | objY1Z0 <-tail objZ0
|
||||||
]| z0<-pZs |mX' <-midsX | mY' <-midsY | objZ0 <-objV
|
]| z0<-pZs |mX' <-midsX | mY' <-midsY | objZ0 <-objV
|
||||||
] `using` parBuffer (max 1 $ div (fromℕ nz) forcesteps) rdeepseq
|
] `using` parBuffer (max 1 $ div (fromℕ nz) forcesteps) rdeepseq
|
||||||
|
|
||||||
segsY = [[[
|
segsY = [[[
|
||||||
fmap (injY y0) $ getSegs (x0,z0) (x1',z1') (obj *$* y0) (objX0Y0Z0, objX1Y0Z0, objX0Y0Z1, objX1Y0Z1) (midA0, midA1, midB0, midB1)
|
injY y0 <$> getSegs (x0,z0) (x1',z1') (obj *$* y0) (objX0Y0Z0, objX1Y0Z0, objX0Y0Z1, objX1Y0Z1) (midA0, midA1, midB0, midB1)
|
||||||
| x0<-pXs | x1'<-tail pXs | midB0<-mB'' | midB1<-mBT' | midA0<-mA'' | midA1<-tail mA'' | objX0Y0Z0<-objY0Z0 | objX1Y0Z0<-tail objY0Z0 | objX0Y0Z1<-objY0Z1 | objX1Y0Z1<-tail objY0Z1
|
| x0<-pXs | x1'<-tail pXs | midB0<-mB'' | midB1<-mBT' | midA0<-mA'' | midA1<-tail mA'' | objX0Y0Z0<-objY0Z0 | objX1Y0Z0<-tail objY0Z0 | objX0Y0Z1<-objY0Z1 | objX1Y0Z1<-tail objY0Z1
|
||||||
]| y0<-pYs | mB'' <-mB' | mBT' <-mBT | mA'' <-mA' | objY0Z0 <-objZ0 | objY0Z1 <-objZ1
|
]| y0<-pYs | mB'' <-mB' | mBT' <-mBT | mA'' <-mA' | objY0Z0 <-objZ0 | objY0Z1 <-objZ1
|
||||||
]| z0<-pZs | z1'<-tail pZs | mB' <-midsX | mBT <-tail midsX | mA' <-midsZ | objZ0 <-objV | objZ1 <-tail objV
|
]| z0<-pZs | z1'<-tail pZs | mB' <-midsX | mBT <-tail midsX | mA' <-midsZ | objZ0 <-objV | objZ1 <-tail objV
|
||||||
] `using` parBuffer (max 1 $ div (fromℕ ny) forcesteps) rdeepseq
|
] `using` parBuffer (max 1 $ div (fromℕ ny) forcesteps) rdeepseq
|
||||||
|
|
||||||
segsX = [[[
|
segsX = [[[
|
||||||
fmap (injX x0) $ getSegs (y0,z0) (y1',z1') (obj $** x0) (objX0Y0Z0, objX0Y1Z0, objX0Y0Z1, objX0Y1Z1) (midA0, midA1, midB0, midB1)
|
injX x0 <$> getSegs (y0,z0) (y1',z1') (obj $** x0) (objX0Y0Z0, objX0Y1Z0, objX0Y0Z1, objX0Y1Z1) (midA0, midA1, midB0, midB1)
|
||||||
| x0<-pXs | midB0<-mB'' | midB1<-mBT' | midA0<-mA'' | midA1<-mA'T | objX0Y0Z0<-objY0Z0 | objX0Y1Z0<-objY1Z0 | objX0Y0Z1<-objY0Z1 | objX0Y1Z1<- objY1Z1
|
| x0<-pXs | midB0<-mB'' | midB1<-mBT' | midA0<-mA'' | midA1<-mA'T | objX0Y0Z0<-objY0Z0 | objX0Y1Z0<-objY1Z0 | objX0Y0Z1<-objY0Z1 | objX0Y1Z1<- objY1Z1
|
||||||
]| y0<-pYs | y1'<-tail pYs | mB'' <-mB' | mBT' <-mBT | mA'' <-mA' | mA'T <-tail mA' | objY0Z0 <-objZ0 | objY1Z0 <-tail objZ0 | objY0Z1 <-objZ1 | objY1Z1 <-tail objZ1
|
]| y0<-pYs | y1'<-tail pYs | mB'' <-mB' | mBT' <-mBT | mA'' <-mA' | mA'T <-tail mA' | objY0Z0 <-objZ0 | objY1Z0 <-tail objZ0 | objY0Z1 <-objZ1 | objY1Z1 <-tail objZ1
|
||||||
]| z0<-pZs | z1'<-tail pZs | mB' <-midsY | mBT <-tail midsY | mA' <-midsZ | objZ0 <- objV | objZ1 <- tail objV
|
]| z0<-pZs | z1'<-tail pZs | mB' <-midsY | mBT <-tail midsY | mA' <-midsZ | objZ0 <- objV | objZ1 <- tail objV
|
||||||
|
@ -11,7 +11,7 @@
|
|||||||
-- output SCAD code, AKA an implicitcad to openscad converter.
|
-- output SCAD code, AKA an implicitcad to openscad converter.
|
||||||
module Graphics.Implicit.Export.SymbolicFormats (scad2, scad3) where
|
module Graphics.Implicit.Export.SymbolicFormats (scad2, scad3) where
|
||||||
|
|
||||||
import Prelude(Either(Left, Right), ($), (*), ($!), (-), (/), pi, error, (+), (==), take, floor, (&&), const, pure, (<>), sequenceA, fmap)
|
import Prelude(Either(Left, Right), ($), (*), ($!), (-), (/), pi, error, (+), (==), take, floor, (&&), const, pure, (<>), sequenceA, fmap, (<$>))
|
||||||
|
|
||||||
import Graphics.Implicit.Definitions(ℝ, SymbolicObj2(RectR, Circle, PolygonR, Complement2, UnionR2, DifferenceR2, IntersectR2, Translate2, Scale2, Rotate2, Outset2, Shell2, EmbedBoxedObj2), SymbolicObj3(Rect3R, Sphere, Cylinder, Complement3, UnionR3, IntersectR3, DifferenceR3, Translate3, Scale3, Rotate3, Rotate3V, Outset3, Shell3, ExtrudeR, ExtrudeRotateR, ExtrudeRM, EmbedBoxedObj3, RotateExtrude, ExtrudeOnEdgeOf))
|
import Graphics.Implicit.Definitions(ℝ, SymbolicObj2(RectR, Circle, PolygonR, Complement2, UnionR2, DifferenceR2, IntersectR2, Translate2, Scale2, Rotate2, Outset2, Shell2, EmbedBoxedObj2), SymbolicObj3(Rect3R, Sphere, Cylinder, Complement3, UnionR3, IntersectR3, DifferenceR3, Translate3, Scale3, Rotate3, Rotate3V, Outset3, Shell3, ExtrudeR, ExtrudeRotateR, ExtrudeRM, EmbedBoxedObj3, RotateExtrude, ExtrudeOnEdgeOf))
|
||||||
import Graphics.Implicit.Export.TextBuilderUtils(Text, Builder, toLazyText, fromLazyText, bf)
|
import Graphics.Implicit.Export.TextBuilderUtils(Text, Builder, toLazyText, fromLazyText, bf)
|
||||||
@ -39,7 +39,7 @@ callToken :: (Text, Text) -> Builder -> [Builder] -> [Reader a Builder] -> Reade
|
|||||||
callToken cs name args [] = pure $ name <> buildArgs cs args <> ";"
|
callToken cs name args [] = pure $ name <> buildArgs cs args <> ";"
|
||||||
callToken cs name args [obj] = fmap ((name <> buildArgs cs args) <>) obj
|
callToken cs name args [obj] = fmap ((name <> buildArgs cs args) <>) obj
|
||||||
callToken cs name args objs = do
|
callToken cs name args objs = do
|
||||||
objs' <- fmap (foldMap (<> "\n")) $ sequenceA objs
|
objs' <- foldMap (<> "\n") <$> sequenceA objs
|
||||||
pure $! name <> buildArgs cs args <> "{\n" <> objs' <> "}\n"
|
pure $! name <> buildArgs cs args <> "{\n" <> objs' <> "}\n"
|
||||||
|
|
||||||
buildArgs :: (Text, Text) -> [Builder] -> Builder
|
buildArgs :: (Text, Text) -> [Builder] -> Builder
|
||||||
|
@ -8,7 +8,7 @@
|
|||||||
|
|
||||||
module Graphics.Implicit.Export.SymbolicObj2 (symbolicGetOrientedContour, symbolicGetContour, symbolicGetContourMesh) where
|
module Graphics.Implicit.Export.SymbolicObj2 (symbolicGetOrientedContour, symbolicGetContour, symbolicGetContourMesh) where
|
||||||
|
|
||||||
import Prelude(fmap, ($), (-), (/), (+), (>), (*), reverse, cos, pi, sin, max, ceiling)
|
import Prelude(fmap, ($), (-), (/), (+), (>), (*), reverse, cos, pi, sin, max, ceiling, (<$>))
|
||||||
|
|
||||||
import Graphics.Implicit.Definitions (ℝ, ℝ2, Fastℕ, SymbolicObj2(RectR, Circle, Translate2, Scale2), Polyline(Polyline), Polytri(Polytri), (⋯*), fromFastℕtoℝ)
|
import Graphics.Implicit.Definitions (ℝ, ℝ2, Fastℕ, SymbolicObj2(RectR, Circle, Translate2, Scale2), Polyline(Polyline), Polytri(Polytri), (⋯*), fromFastℕtoℝ)
|
||||||
|
|
||||||
@ -23,7 +23,7 @@ import Graphics.Implicit.Export.Render (getContour)
|
|||||||
import Data.VectorSpace ((^/), magnitude)
|
import Data.VectorSpace ((^/), magnitude)
|
||||||
|
|
||||||
symbolicGetOrientedContour :: ℝ -> SymbolicObj2 -> [Polyline]
|
symbolicGetOrientedContour :: ℝ -> SymbolicObj2 -> [Polyline]
|
||||||
symbolicGetOrientedContour res symbObj = fmap orient $ symbolicGetContour res symbObj
|
symbolicGetOrientedContour res symbObj = orient <$> symbolicGetContour res symbObj
|
||||||
where
|
where
|
||||||
obj = getImplicit2 symbObj
|
obj = getImplicit2 symbObj
|
||||||
-- FIXME: cowardly case handling.
|
-- FIXME: cowardly case handling.
|
||||||
@ -56,10 +56,10 @@ appOpPolyline :: (ℝ2 -> ℝ2) -> Polyline -> Polyline
|
|||||||
appOpPolyline op (Polyline xs) = Polyline $ fmap op xs
|
appOpPolyline op (Polyline xs) = Polyline $ fmap op xs
|
||||||
|
|
||||||
symbolicGetContourMesh :: ℝ -> SymbolicObj2 -> [Polytri]
|
symbolicGetContourMesh :: ℝ -> SymbolicObj2 -> [Polytri]
|
||||||
symbolicGetContourMesh res (Translate2 v obj) = fmap (\(Polytri (a,b,c)) -> Polytri (a + v, b + v, c + v) ) $
|
symbolicGetContourMesh res (Translate2 v obj) = (\(Polytri (a,b,c)) -> Polytri (a + v, b + v, c + v)) <$>
|
||||||
symbolicGetContourMesh res obj
|
symbolicGetContourMesh res obj
|
||||||
symbolicGetContourMesh res (Scale2 s@(a,b) obj) = fmap (\(Polytri (c,d,e)) -> Polytri (c ⋯* s, d ⋯* s, e ⋯* s) ) $
|
symbolicGetContourMesh res (Scale2 s@(a,b) obj) = (\(Polytri (c,d,e)) -> Polytri (c ⋯* s, d ⋯* s, e ⋯* s)) <$>
|
||||||
symbolicGetContourMesh (res/sc) obj where sc = max a b
|
symbolicGetContourMesh (res/sc) obj where sc = max a b
|
||||||
symbolicGetContourMesh _ (RectR 0 (x1,y1) (x2,y2)) = [Polytri ((x1,y1), (x2,y1), (x2,y2)), Polytri ((x2,y2), (x1,y2), (x1,y1)) ]
|
symbolicGetContourMesh _ (RectR 0 (x1,y1) (x2,y2)) = [Polytri ((x1,y1), (x2,y1), (x2,y2)), Polytri ((x2,y2), (x1,y2), (x1,y1)) ]
|
||||||
-- FIXME: magic number.
|
-- FIXME: magic number.
|
||||||
symbolicGetContourMesh res (Circle r) =
|
symbolicGetContourMesh res (Circle r) =
|
||||||
|
@ -78,7 +78,7 @@ cleanupTris tris =
|
|||||||
|
|
||||||
-- | Generate an STL file is ASCII format.
|
-- | Generate an STL file is ASCII format.
|
||||||
stl :: TriangleMesh -> Text
|
stl :: TriangleMesh -> Text
|
||||||
stl triangles = toLazyText $ stlHeader <> (foldMap triangle $ unmesh $ cleanupTris triangles) <> stlFooter
|
stl triangles = toLazyText $ stlHeader <> foldMap triangle (unmesh $ cleanupTris triangles) <> stlFooter
|
||||||
where
|
where
|
||||||
stlHeader :: Builder
|
stlHeader :: Builder
|
||||||
stlHeader = "solid ImplictCADExport\n"
|
stlHeader = "solid ImplictCADExport\n"
|
||||||
@ -107,7 +107,7 @@ float32LE = writeStorable . LE
|
|||||||
|
|
||||||
-- | Generate an STL file in it's binary format.
|
-- | Generate an STL file in it's binary format.
|
||||||
binaryStl :: TriangleMesh -> ByteString
|
binaryStl :: TriangleMesh -> ByteString
|
||||||
binaryStl triangles = toLazyByteString $ header <> lengthField <> (foldMap triangle $ unmesh $ cleanupTris triangles)
|
binaryStl triangles = toLazyByteString $ header <> lengthField <> foldMap triangle (unmesh $ cleanupTris triangles)
|
||||||
where header = fromByteString $ replicate 80 0
|
where header = fromByteString $ replicate 80 0
|
||||||
lengthField = fromWord32le $ toEnum $ length $ unmesh $ cleanupTris triangles
|
lengthField = fromWord32le $ toEnum $ length $ unmesh $ cleanupTris triangles
|
||||||
triangle (Triangle (a,b,c)) = normalV (a,b,c) <> point a <> point b <> point c <> fromWord16le 0
|
triangle (Triangle (a,b,c)) = normalV (a,b,c) <> point a <> point b <> point c <> fromWord16le 0
|
||||||
|
@ -191,8 +191,8 @@ data SourcePosition = SourcePosition
|
|||||||
deriving (Eq)
|
deriving (Eq)
|
||||||
|
|
||||||
instance Show SourcePosition where
|
instance Show SourcePosition where
|
||||||
show (SourcePosition line col []) = "line " <> show ((fromFastℕ line) :: Int) <> ", column " <> show ((fromFastℕ col) :: Int)
|
show (SourcePosition line col []) = "line " <> show (fromFastℕ line :: Int) <> ", column " <> show (fromFastℕ col :: Int)
|
||||||
show (SourcePosition line col filePath) = "line " <> show ((fromFastℕ line) :: Int) <> ", column " <> show ((fromFastℕ col) :: Int) <> ", file " <> filePath
|
show (SourcePosition line col filePath) = "line " <> show (fromFastℕ line :: Int) <> ", column " <> show (fromFastℕ col :: Int) <> ", file " <> filePath
|
||||||
|
|
||||||
-- | The types of messages the execution engine can send back to the application.
|
-- | The types of messages the execution engine can send back to the application.
|
||||||
data MessageType = TextOut -- text intetionally output by the ExtOpenScad program.
|
data MessageType = TextOut -- text intetionally output by the ExtOpenScad program.
|
||||||
|
@ -69,7 +69,7 @@ patMatch _ _ = Nothing
|
|||||||
|
|
||||||
-- | Construct a VarLookup from the given Pattern and OVal, if possible.
|
-- | Construct a VarLookup from the given Pattern and OVal, if possible.
|
||||||
matchPat :: Pattern -> OVal -> Maybe VarLookup
|
matchPat :: Pattern -> OVal -> Maybe VarLookup
|
||||||
matchPat pat val = VarLookup . fromList . zip (fmap Symbol $ patVars pat) <$> patMatch pat val
|
matchPat pat val = VarLookup . fromList . zip (Symbol <$> patVars pat) <$> patMatch pat val
|
||||||
|
|
||||||
-- | The entry point from StateC. evaluates an expression, pureing the result, and moving any error messages generated into the calling StateC.
|
-- | The entry point from StateC. evaluates an expression, pureing the result, and moving any error messages generated into the calling StateC.
|
||||||
evalExpr :: SourcePosition -> Expr -> StateC OVal
|
evalExpr :: SourcePosition -> Expr -> StateC OVal
|
||||||
|
@ -11,7 +11,7 @@
|
|||||||
|
|
||||||
module Graphics.Implicit.ExtOpenScad.Eval.Statement (runStatementI) where
|
module Graphics.Implicit.ExtOpenScad.Eval.Statement (runStatementI) where
|
||||||
|
|
||||||
import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left, Right), (.), ($), show, pure, (<>), reverse, fst, snd, readFile, filter, length, (&&), (==), (/=), fmap, notElem, elem, not, zip, init, last, null, String, (*>))
|
import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left, Right), (.), ($), show, pure, (<>), reverse, fst, snd, readFile, filter, length, (&&), (==), (/=), fmap, notElem, elem, not, zip, init, last, null, String, (*>), (<$>))
|
||||||
|
|
||||||
import Graphics.Implicit.ExtOpenScad.Definitions (
|
import Graphics.Implicit.ExtOpenScad.Definitions (
|
||||||
Statement(Include, (:=), If, NewModule, ModuleCall, DoNothing),
|
Statement(Include, (:=), If, NewModule, ModuleCall, DoNothing),
|
||||||
@ -195,22 +195,22 @@ runStatementI (StatementI sourcePos (ModuleCall (Symbol name) argsExpr suite)) =
|
|||||||
valUnnamed = unnamedParameters argsExpr
|
valUnnamed = unnamedParameters argsExpr
|
||||||
mapFromUnnamed :: [(Symbol, Expr)]
|
mapFromUnnamed :: [(Symbol, Expr)]
|
||||||
mapFromUnnamed = zip notMappedNotDefaultable valUnnamed
|
mapFromUnnamed = zip notMappedNotDefaultable valUnnamed
|
||||||
missingNotDefaultable = filter (`notElem` (mappedDefaulted <> mappedNotDefaulted <> (fmap fst mapFromUnnamed))) valNotDefaulted
|
missingNotDefaultable = filter (`notElem` (mappedDefaulted <> mappedNotDefaulted <> fmap fst mapFromUnnamed)) valNotDefaulted
|
||||||
extraUnnamed = filter (`notElem` (valDefaulted <> valNotDefaulted)) $ namedParameters argsExpr
|
extraUnnamed = filter (`notElem` (valDefaulted <> valNotDefaulted)) $ namedParameters argsExpr
|
||||||
parameterReport = "Passed " <>
|
parameterReport = "Passed " <>
|
||||||
(if (null valNamed && null valUnnamed) then "no parameters" else "" ) <>
|
(if null valNamed && null valUnnamed then "no parameters" else "" ) <>
|
||||||
(if not (null valNamed) then show (length valNamed) <> (if length valNamed == 1 then " named parameter" else " named parameters") else "" ) <>
|
(if not (null valNamed) then show (length valNamed) <> (if length valNamed == 1 then " named parameter" else " named parameters") else "" ) <>
|
||||||
(if not (null valNamed) && not (null valUnnamed) then ", and " else "") <>
|
(if not (null valNamed) && not (null valUnnamed) then ", and " else "") <>
|
||||||
(if not (null valUnnamed) then show (length valUnnamed) <> (if length valUnnamed == 1 then " un-named parameter." else " un-named parameters.") else ".") <>
|
(if not (null valUnnamed) then show (length valUnnamed) <> (if length valUnnamed == 1 then " un-named parameter." else " un-named parameters.") else ".") <>
|
||||||
(if not (null missingNotDefaultable) then
|
(if not (null missingNotDefaultable) then
|
||||||
(if length missingNotDefaultable == 1
|
(if length missingNotDefaultable == 1
|
||||||
then " Couldn't match one parameter: " <> showSymbol (last missingNotDefaultable)
|
then " Couldn't match one parameter: " <> showSymbol (last missingNotDefaultable)
|
||||||
else " Couldn't match " <> show (length missingNotDefaultable) <> " parameters: " <> intercalate ", " (fmap showSymbol $ init missingNotDefaultable) <> " and " <> showSymbol (last missingNotDefaultable) <> "."
|
else " Couldn't match " <> show (length missingNotDefaultable) <> " parameters: " <> intercalate ", " (showSymbol <$> init missingNotDefaultable) <> " and " <> showSymbol (last missingNotDefaultable) <> "."
|
||||||
) else "") <>
|
) else "") <>
|
||||||
(if not (null extraUnnamed) then
|
(if not (null extraUnnamed) then
|
||||||
(if length extraUnnamed == 1
|
(if length extraUnnamed == 1
|
||||||
then " Had one extra parameter: " <> showSymbol (last extraUnnamed)
|
then " Had one extra parameter: " <> showSymbol (last extraUnnamed)
|
||||||
else " Had " <> show (length extraUnnamed) <> " extra parameters. They are:" <> intercalate ", " (fmap showSymbol $ init extraUnnamed) <> " and " <> showSymbol (last extraUnnamed) <> "."
|
else " Had " <> show (length extraUnnamed) <> " extra parameters. They are:" <> intercalate ", " (showSymbol <$> init extraUnnamed) <> " and " <> showSymbol (last extraUnnamed) <> "."
|
||||||
) else "")
|
) else "")
|
||||||
showSymbol :: Symbol -> String
|
showSymbol :: Symbol -> String
|
||||||
showSymbol (Symbol sym) = show sym
|
showSymbol (Symbol sym) = show sym
|
||||||
|
@ -11,7 +11,7 @@
|
|||||||
module Graphics.Implicit.ExtOpenScad.Util.ArgParser (argument, doc, defaultTo, example, test, eulerCharacteristic, argMap) where
|
module Graphics.Implicit.ExtOpenScad.Util.ArgParser (argument, doc, defaultTo, example, test, eulerCharacteristic, argMap) where
|
||||||
|
|
||||||
-- imported twice, once qualified. null from Data.Map conflicts with null from Prelude.
|
-- imported twice, once qualified. null from Data.Map conflicts with null from Prelude.
|
||||||
import Prelude(String, Maybe(Just, Nothing), ($), (<>), show, error, return, fmap, snd, filter, (.), fst, foldl1, not, (&&))
|
import Prelude(String, Maybe(Just, Nothing), ($), (<>), show, error, return, fmap, snd, filter, (.), fst, foldl1, not, (&&), (<$>))
|
||||||
import qualified Prelude as P (null)
|
import qualified Prelude as P (null)
|
||||||
|
|
||||||
import Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch, APTerminator, APFailIf, APExample), OVal (OError), TestInvariant(EulerCharacteristic), Symbol, VarLookup(VarLookup))
|
import Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch, APTerminator, APFailIf, APExample), OVal (OError), TestInvariant(EulerCharacteristic), Symbol, VarLookup(VarLookup))
|
||||||
@ -82,8 +82,8 @@ argMap ::
|
|||||||
-> ArgParser a -- ^ ArgParser to apply them to
|
-> ArgParser a -- ^ ArgParser to apply them to
|
||||||
-> (Maybe a, [String]) -- ^ (result, error messages)
|
-> (Maybe a, [String]) -- ^ (result, error messages)
|
||||||
argMap args = argMap2 unnamedArgs (VarLookup $ fromList namedArgs) where
|
argMap args = argMap2 unnamedArgs (VarLookup $ fromList namedArgs) where
|
||||||
unnamedArgs = fmap snd $ filter (isNothing . fst) args
|
unnamedArgs = snd <$> filter (isNothing . fst) args
|
||||||
namedArgs = fmap (first fromJust) $ filter (isJust . fst) args
|
namedArgs = first fromJust <$> filter (isJust . fst) args
|
||||||
|
|
||||||
argMap2 :: [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
|
argMap2 :: [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
|
||||||
argMap2 unnamedArgs namedArgs (APBranch branches) =
|
argMap2 unnamedArgs namedArgs (APBranch branches) =
|
||||||
|
@ -5,7 +5,7 @@
|
|||||||
|
|
||||||
module Graphics.Implicit.ObjectUtil.GetImplicit3 (getImplicit3) where
|
module Graphics.Implicit.ObjectUtil.GetImplicit3 (getImplicit3) where
|
||||||
|
|
||||||
import Prelude (Either(Left, Right), abs, (-), (/), (*), sqrt, (+), atan2, max, cos, fmap, minimum, ($), (**), sin, pi, (.), Bool(True, False), ceiling, floor, pure, error, head, tail, (>), (&&), (<), (==), otherwise)
|
import Prelude (Either(Left, Right), abs, (-), (/), (*), sqrt, (+), atan2, max, cos, fmap, minimum, ($), (**), sin, pi, (.), Bool(True, False), ceiling, floor, pure, error, head, tail, (>), (&&), (<), (==), otherwise, (<$>))
|
||||||
|
|
||||||
import Graphics.Implicit.Definitions (ℝ, ℕ, ℝ2, ℝ3, (⋯/), Obj3,
|
import Graphics.Implicit.Definitions (ℝ, ℕ, ℝ2, ℝ3, (⋯/), Obj3,
|
||||||
SymbolicObj3(Shell3, UnionR3, IntersectR3, DifferenceR3, Translate3, Scale3, Rotate3,
|
SymbolicObj3(Shell3, UnionR3, IntersectR3, DifferenceR3, Translate3, Scale3, Rotate3,
|
||||||
@ -49,25 +49,21 @@ getImplicit3 (Complement3 symbObj) =
|
|||||||
in
|
in
|
||||||
\p -> - obj p
|
\p -> - obj p
|
||||||
getImplicit3 (UnionR3 r symbObjs) =
|
getImplicit3 (UnionR3 r symbObjs) =
|
||||||
let
|
\p -> rminimum r $ fmap ($p) $ getImplicit3 <$> symbObjs
|
||||||
objs = fmap getImplicit3 symbObjs
|
|
||||||
in
|
|
||||||
\p -> rminimum r $ fmap ($p) objs
|
|
||||||
getImplicit3 (IntersectR3 r symbObjs) =
|
getImplicit3 (IntersectR3 r symbObjs) =
|
||||||
let
|
\p -> rmaximum r $ fmap ($p) $ getImplicit3 <$> symbObjs
|
||||||
objs = fmap getImplicit3 symbObjs
|
|
||||||
in
|
|
||||||
\p -> rmaximum r $ fmap ($p) objs
|
|
||||||
getImplicit3 (DifferenceR3 r symbObjs) =
|
getImplicit3 (DifferenceR3 r symbObjs) =
|
||||||
let
|
let
|
||||||
tailObjs = fmap getImplicit3 $ tail symbObjs
|
tailObjs = getImplicit3 <$> tail symbObjs
|
||||||
headObj = getImplicit3 $ head symbObjs
|
headObj = getImplicit3 $ head symbObjs
|
||||||
complement :: Obj3 -> ℝ3 -> ℝ
|
complement :: Obj3 -> ℝ3 -> ℝ
|
||||||
complement obj' p = - obj' p
|
complement obj' p = - obj' p
|
||||||
in
|
in
|
||||||
\p -> do
|
\p -> do
|
||||||
let
|
let
|
||||||
maxTail = rmaximum r $ fmap ($p) $ fmap complement tailObjs
|
maxTail = rmaximum r $ fmap ($p) $ complement <$> tailObjs
|
||||||
if maxTail > -minℝ && maxTail < minℝ
|
if maxTail > -minℝ && maxTail < minℝ
|
||||||
then rmax r (headObj p) minℝ
|
then rmax r (headObj p) minℝ
|
||||||
else rmax r (headObj p) maxTail
|
else rmax r (headObj p) maxTail
|
||||||
|
@ -6,7 +6,7 @@
|
|||||||
|
|
||||||
-- Let's be explicit about where things come from :)
|
-- Let's be explicit about where things come from :)
|
||||||
|
|
||||||
import Prelude (($), (*), (/), String, IO, cos, pi, fmap, zip3, Either(Left, Right), fromIntegral, (<>))
|
import Prelude (($), (*), (/), String, IO, cos, pi, fmap, zip3, Either(Left, Right), fromIntegral, (<>), (<$>))
|
||||||
|
|
||||||
-- Use criterion for benchmarking. see <http://www.serpentine.com/criterion/>
|
-- Use criterion for benchmarking. see <http://www.serpentine.com/criterion/>
|
||||||
import Criterion.Main (Benchmark, bgroup, bench, nf, nfAppIO, defaultMain)
|
import Criterion.Main (Benchmark, bgroup, bench, nf, nfAppIO, defaultMain)
|
||||||
@ -48,12 +48,13 @@ object2 = squarePipe (10,10,10) 1 100
|
|||||||
squarePipe :: (ℝ,ℝ,ℝ) -> ℝ -> ℝ -> SymbolicObj3
|
squarePipe :: (ℝ,ℝ,ℝ) -> ℝ -> ℝ -> SymbolicObj3
|
||||||
squarePipe (x,y,z) diameter precision =
|
squarePipe (x,y,z) diameter precision =
|
||||||
union
|
union
|
||||||
$ fmap (\start-> translate start
|
((\start-> translate start
|
||||||
$ rect3R 0 (0,0,0) (diameter,diameter,diameter)
|
$ rect3R 0 (0,0,0) (diameter,diameter,diameter)
|
||||||
)
|
)
|
||||||
$ zip3 (fmap (\n->(fromIntegral n/precision)*x) [0..100::Fastℕ])
|
<$>
|
||||||
|
zip3 (fmap (\n->(fromIntegral n/precision)*x) [0..100::Fastℕ])
|
||||||
(fmap (\n->(fromIntegral n/precision)*y) [0..100::Fastℕ])
|
(fmap (\n->(fromIntegral n/precision)*y) [0..100::Fastℕ])
|
||||||
(fmap (\n->(fromIntegral n/precision)*z) [0..100::Fastℕ])
|
(fmap (\n->(fromIntegral n/precision)*z) [0..100::Fastℕ]))
|
||||||
|
|
||||||
-- | A third 3d object to benchmark.
|
-- | A third 3d object to benchmark.
|
||||||
object3 :: SymbolicObj3
|
object3 :: SymbolicObj3
|
||||||
|
@ -349,7 +349,7 @@ run rawargs = do
|
|||||||
_ -> hPutStr stderr "ERROR: File contains a mixture of 2D and 3D objects, what do you want to render?\n"
|
_ -> hPutStr stderr "ERROR: File contains a mixture of 2D and 3D objects, what do you want to render?\n"
|
||||||
|
|
||||||
-- | Always display our warnings, errors, and other non-textout messages on stderr.
|
-- | Always display our warnings, errors, and other non-textout messages on stderr.
|
||||||
hPutStr stderr $ unlines $ fmap show $ filter (not . isTextOut) messages
|
hPutStr stderr $ unlines $ show <$> filter (not . isTextOut) messages
|
||||||
|
|
||||||
let textOutHandler =
|
let textOutHandler =
|
||||||
case () of
|
case () of
|
||||||
@ -357,7 +357,7 @@ run rawargs = do
|
|||||||
_ | rawEcho args -> textOutBare
|
_ | rawEcho args -> textOutBare
|
||||||
_ -> show
|
_ -> show
|
||||||
|
|
||||||
hPutStr hMessageOutput $ unlines $ fmap textOutHandler $ filter isTextOut messages
|
hPutStr hMessageOutput $ unlines $ textOutHandler <$> filter isTextOut messages
|
||||||
|
|
||||||
-- | The entry point. Use the option parser then run the extended OpenScad code.
|
-- | The entry point. Use the option parser then run the extended OpenScad code.
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
|
@ -36,7 +36,7 @@ infixr 1 -->
|
|||||||
-- | Types
|
-- | Types
|
||||||
|
|
||||||
-- | An even smaller wrapper which runs a program, and only returns the generated messages. for the test suite.
|
-- | An even smaller wrapper which runs a program, and only returns the generated messages. for the test suite.
|
||||||
getOpenscadMessages :: ScadOpts -> [String] -> String -> IO ([Message])
|
getOpenscadMessages :: ScadOpts -> [String] -> String -> IO [Message]
|
||||||
getOpenscadMessages scadOpts constants source = do
|
getOpenscadMessages scadOpts constants source = do
|
||||||
(_, _, _, messages) <- runOpenscad scadOpts constants source
|
(_, _, _, messages) <- runOpenscad scadOpts constants source
|
||||||
return messages
|
return messages
|
||||||
|
Loading…
Reference in New Issue
Block a user