mirror of
https://github.com/Haskell-Things/ImplicitCAD.git
synced 2024-09-11 04:55:41 +03:00
Whitespace cleanup
This commit is contained in:
parent
8478f7346c
commit
9c1bfc77c4
@ -6,4 +6,4 @@ out = union [
|
||||
translate (40,40) (circle 30) ]
|
||||
|
||||
main = writeSVG 2 "example11.svg" out
|
||||
|
||||
|
||||
|
@ -4,5 +4,5 @@ import Graphics.Implicit
|
||||
out = unionR 14 [
|
||||
rectR 0 (-40,-40) (40,40),
|
||||
translate (40,40) (circle 30) ]
|
||||
|
||||
|
||||
main = writeSVG 2 "example12.svg" out
|
||||
|
@ -203,7 +203,7 @@ data SymbolicObj2 =
|
||||
deriving Show
|
||||
|
||||
-- | A symbolic 3D format!
|
||||
data SymbolicObj3 =
|
||||
data SymbolicObj3 =
|
||||
-- Primitives
|
||||
Rect3R ℝ ℝ3 ℝ3
|
||||
| Sphere ℝ
|
||||
|
@ -18,8 +18,8 @@ import Graphics.Implicit.ObjectUtil (getImplicit3, getImplicit2, getBox3, getBox
|
||||
|
||||
import Graphics.Implicit.Export.SymbolicObj3 (symbolicGetMesh)
|
||||
import Graphics.Implicit.Export.SymbolicObj2 (symbolicGetContour)
|
||||
import Graphics.Implicit.Export.Util (normTriangle)
|
||||
|
||||
import Graphics.Implicit.Export.Util (normTriangle)
|
||||
|
||||
import Graphics.Implicit.Export.RayTrace (dynamicImage, Color, average, Camera(Camera), Light(Light), Scene(Scene), traceRay, cameraRay)
|
||||
|
||||
import Codec.Picture (DynamicImage, generateImage, PixelRGBA8(PixelRGBA8))
|
||||
@ -56,21 +56,21 @@ instance DiscreteAproxable SymbolicObj3 DynamicImage where
|
||||
lights = [Light (x1-deviation*(1.5::ℝ), y1 - (0.4::ℝ)*(y2-y1), avZ) ((0.03::ℝ)*deviation) ]
|
||||
scene = Scene obj (PixelRGBA8 200 200 230 255) lights (PixelRGBA8 255 255 255 0)
|
||||
pixelRenderer :: Fastℕ -> Fastℕ -> Color
|
||||
pixelRenderer a b = renderScreen
|
||||
pixelRenderer a b = renderScreen
|
||||
((fromIntegral a :: ℝ)/w - (0.5::ℝ)) ((fromIntegral b :: ℝ)/h - (0.5 ::ℝ))
|
||||
renderScreen :: ℝ -> ℝ -> Color
|
||||
renderScreen a b =
|
||||
average [
|
||||
traceRay
|
||||
traceRay
|
||||
(cameraRay camera ((a,b) ^+^ ( 0.25/w, 0.25/h)))
|
||||
2 box scene,
|
||||
traceRay
|
||||
traceRay
|
||||
(cameraRay camera ((a,b) ^+^ (-0.25/w, 0.25/h)))
|
||||
0.5 box scene,
|
||||
traceRay
|
||||
traceRay
|
||||
(cameraRay camera ((a,b) ^+^ (0.25/w, -0.25/h)))
|
||||
0.5 box scene,
|
||||
traceRay
|
||||
traceRay
|
||||
(cameraRay camera ((a,b) ^+^ (-0.25/w,-0.25/h)))
|
||||
0.5 box scene
|
||||
]
|
||||
@ -102,4 +102,4 @@ instance DiscreteAproxable SymbolicObj2 DynamicImage where
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
@ -30,7 +30,7 @@ svg plines = renderSvg . svg11 . svg' $ plines
|
||||
(xmin, xmax, ymin, ymax) = (minimum xs - margin, maximum xs + margin, minimum ys - margin, maximum ys + margin)
|
||||
where margin = strokeWidth / 2
|
||||
(xs,ys) = unzip (concat plines)
|
||||
|
||||
|
||||
svg11 = docTypeSvg ! A.version "1.1"
|
||||
! A.width (stringValue $ show (xmax-xmin) ++ "mm")
|
||||
! A.height (stringValue $ show (ymax-ymin) ++ "mm")
|
||||
@ -38,11 +38,11 @@ svg plines = renderSvg . svg11 . svg' $ plines
|
||||
|
||||
-- The reason this isn't totally straightforwards is that svg has different coordinate system
|
||||
-- and we need to compute the requisite translation.
|
||||
svg' [] = mempty
|
||||
svg' [] = mempty
|
||||
-- When we have a known point, we can compute said transformation:
|
||||
svg' polylines = thinBlueGroup $ mapM_ poly polylines
|
||||
|
||||
poly line = polyline ! A.points pointList
|
||||
poly line = polyline ! A.points pointList
|
||||
where pointList = toValue $ toLazyText $ mconcat [bf (x-xmin) <> "," <> bf (ymax - y) <> " " | (x,y) <- line]
|
||||
|
||||
-- Instead of setting styles on every polyline, we wrap the lines in a group element and set the styles on it:
|
||||
@ -87,4 +87,4 @@ hacklabLaserGCode polylines = toLazyText $ gcodeHeader <> mconcat (map interpret
|
||||
,mconcat [ "G01 " <> gcodeXY point <> "\n" | point <- others]
|
||||
,"M63 P0 (laser off)\n\n"
|
||||
]
|
||||
interpretPolyline [] = mempty
|
||||
interpretPolyline [] = mempty
|
||||
|
@ -54,8 +54,8 @@ s `colorMult` (PixelRGBA8 a b c d) = color (s `mult` a) (s `mult` b) (s `mult` c
|
||||
mult x y = round . bound . toRational $ x * y
|
||||
|
||||
average :: [Color] -> Color
|
||||
average l =
|
||||
let
|
||||
average l =
|
||||
let
|
||||
((rs, gs), (bs, as)) = (unzip *** unzip) . unzip $ map
|
||||
(\(PixelRGBA8 r g b a) -> ((fromIntegral r, fromIntegral g), (fromIntegral b, fromIntegral a)))
|
||||
l :: (([ℝ], [ℝ]), ([ℝ],[ℝ]))
|
||||
@ -103,7 +103,7 @@ intersection r@(Ray p v) ((a, aval),b) res obj =
|
||||
a' = a + step
|
||||
a'val = obj (p ^+^ a'*^v)
|
||||
in if a'val < 0
|
||||
then
|
||||
then
|
||||
let a'' = refine (a,a') (\s -> obj (p ^+^ s*^v))
|
||||
in Just (p ^+^ a''*^v)
|
||||
else if a' < b
|
||||
@ -111,7 +111,7 @@ intersection r@(Ray p v) ((a, aval),b) res obj =
|
||||
else Nothing
|
||||
|
||||
refine :: ℝ2 -> (ℝ -> ℝ) -> ℝ
|
||||
refine (a, b) obj =
|
||||
refine (a, b) obj =
|
||||
let
|
||||
(aval, bval) = (obj a, obj b)
|
||||
in if bval < aval
|
||||
@ -120,7 +120,7 @@ refine (a, b) obj =
|
||||
|
||||
refine' :: ℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ
|
||||
refine' 0 (a, _) _ _ = a
|
||||
refine' n (a, b) (aval, bval) obj =
|
||||
refine' n (a, b) (aval, bval) obj =
|
||||
let
|
||||
mid = (a+b)/(2::ℝ)
|
||||
midval = obj mid
|
||||
@ -160,12 +160,12 @@ traceRay ray@(Ray cameraP cameraV) step box (Scene obj objColor lights defaultCo
|
||||
proj a' b' = (a'⋅b')*^b'
|
||||
dist = vectorDistance p lightPos
|
||||
illumination = max 0 (normal ⋅ unitV) * lightIntensity * (25 /dist)
|
||||
rV =
|
||||
rV =
|
||||
let
|
||||
normalComponent = proj v' normal
|
||||
parComponent = v' - normalComponent
|
||||
in
|
||||
normalComponent - parComponent
|
||||
normalComponent - parComponent
|
||||
return $ illumination*(3 + 0.3*abs(rV ⋅ cameraV)*abs(rV ⋅ cameraV))
|
||||
)
|
||||
Nothing -> defaultColor
|
||||
|
@ -189,7 +189,7 @@ getMesh p1@(x1,y1,z1) p2 res obj =
|
||||
|
||||
in
|
||||
-- (5) merge squares, etc
|
||||
cleanupTris . mergedSquareTris . concat . concat $ concat sqTris
|
||||
cleanupTris . mergedSquareTris . concat . concat $ concat sqTris
|
||||
|
||||
-- Removes triangles that are empty, when converting their positions to Float resolution.
|
||||
-- NOTE: this will need to be disabled for AMF, and other triangle formats that can handle Double.
|
||||
|
@ -17,10 +17,10 @@ import Control.Monad.Reader (Reader, runReader, return, fmap, sequence, ask)
|
||||
|
||||
import Data.List (intersperse)
|
||||
|
||||
scad2 :: ℝ -> SymbolicObj2 -> Text
|
||||
scad2 :: ℝ -> SymbolicObj2 -> Text
|
||||
scad2 res obj = toLazyText $ runReader (buildS2 obj) res
|
||||
|
||||
scad3 :: ℝ -> SymbolicObj3 -> Text
|
||||
scad3 :: ℝ -> SymbolicObj3 -> Text
|
||||
scad3 res obj = toLazyText $ runReader (buildS3 obj) res
|
||||
|
||||
-- used by rotate2 and rotate3
|
||||
@ -93,7 +93,7 @@ buildS3 (ExtrudeRM r (Just twist) Nothing Nothing obj (Left height)) | r == 0 =
|
||||
call "rotate" ["0","0", bf $ twist h] [
|
||||
callNaked "linear_extrude" ["height = " <> bf res, "twist = " <> bf (twist (h+res) - twist h)][
|
||||
buildS2 obj
|
||||
]
|
||||
]
|
||||
] | h <- init [0, res .. height]
|
||||
]
|
||||
|
||||
|
@ -197,13 +197,13 @@ symbolicGetMesh res (ExtrudeRM r twist scale translate obj2 h) =
|
||||
map transformTriangle (side_tris ++ bottom_tris ++ top_tris)
|
||||
-}
|
||||
|
||||
symbolicGetMesh res inputObj@(UnionR3 r objs) =
|
||||
symbolicGetMesh res inputObj@(UnionR3 r objs) =
|
||||
let
|
||||
boxes = map getBox3 objs
|
||||
boxedObjs = zip boxes objs
|
||||
|
||||
|
||||
sepFree :: forall a. [((ℝ3, ℝ3), a)] -> ([a], [a])
|
||||
sepFree ((box,obj):others) =
|
||||
sepFree ((box,obj):others) =
|
||||
if length (filter (box3sWithin r box) boxes) > 1
|
||||
then first ((:) obj) $ sepFree others
|
||||
else second ((:) obj) $ sepFree others
|
||||
@ -212,7 +212,7 @@ symbolicGetMesh res inputObj@(UnionR3 r objs) =
|
||||
(dependants, independents) = sepFree boxedObjs
|
||||
in if null independents
|
||||
then case rebound3 (getImplicit3 inputObj, getBox3 inputObj) of
|
||||
(obj, (a,b)) -> getMesh a b res obj
|
||||
(obj, (a,b)) -> getMesh a b res obj
|
||||
else if null dependants
|
||||
then concatMap (symbolicGetMesh res) independents
|
||||
else concatMap (symbolicGetMesh res) independents
|
||||
|
@ -97,7 +97,7 @@ jsTHREE triangles = toLazyText $ header <> vertcode <> facecode <> footer
|
||||
v (x,y,z) = "v(" <> bf x <> "," <> bf y <> "," <> bf z <> ");\n"
|
||||
-- A face line
|
||||
f :: Fastℕ -> Fastℕ -> Fastℕ -> Builder
|
||||
f posa posb posc =
|
||||
f posa posb posc =
|
||||
"f(" <> buildInt posa <> "," <> buildInt posb <> "," <> buildInt posc <> ");"
|
||||
verts = do
|
||||
-- extract the vertices for each triangle
|
||||
|
@ -74,7 +74,6 @@ defaultFunctionsSpecial =
|
||||
("map", toOObj $ flip
|
||||
(map :: (OVal -> OVal) -> [OVal] -> [OVal] )
|
||||
)
|
||||
|
||||
]
|
||||
|
||||
defaultModules :: [(String, OVal)]
|
||||
|
@ -24,9 +24,8 @@ import Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, matchPat)
|
||||
import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram)
|
||||
|
||||
import Data.Maybe(fromMaybe)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import Control.Monad (forM_, forM, mapM_)
|
||||
import Control.Monad (forM_, forM, mapM_)
|
||||
import Control.Monad.State (get, liftIO, mapM, runStateT, (>>))
|
||||
import qualified System.FilePath as FilePath
|
||||
|
||||
|
@ -13,7 +13,7 @@ import Graphics.Implicit.Definitions (ℝ)
|
||||
-- The parsec parsing library.
|
||||
import Text.ParserCombinators.Parsec (GenParser, string, many1, digit, char, many, noneOf, sepBy, sepBy1, optionMaybe, try)
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (Expr(Var, LitE, ListE, (:$)), OVal(ONum, OString, OBool, OUndefined), collector)
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (Expr(Var, LitE, ListE, (:$)), OVal(ONum, OString, OBool, OUndefined), collector)
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Parser.Util (variableSymb, (?:), (*<|>), genSpace, padString)
|
||||
|
||||
|
@ -199,7 +199,7 @@ cylinder = moduleWithoutSuite "cylinder" $ do
|
||||
|
||||
circle :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||
circle = moduleWithoutSuite "circle" $ do
|
||||
|
||||
|
||||
example "circle(r=10); // circle"
|
||||
example "circle(r=5, $fn=6); //hexagon"
|
||||
|
||||
@ -223,9 +223,9 @@ circle = moduleWithoutSuite "circle" $ do
|
||||
|
||||
polygon :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||
polygon = moduleWithoutSuite "polygon" $ do
|
||||
|
||||
|
||||
example "polygon ([(0,0), (0,10), (10,0)]);"
|
||||
|
||||
|
||||
points :: [ℝ2] <- argument "points"
|
||||
`doc` "vertices of the polygon"
|
||||
paths :: [ℕ] <- argument "paths"
|
||||
@ -289,7 +289,7 @@ translate = moduleWithSuite "translate" $ \children -> do
|
||||
Left x -> (x,0,0)
|
||||
Right (Left (x,y) ) -> (x,y,0)
|
||||
Right (Right (x,y,z)) -> (x,y,z)
|
||||
|
||||
|
||||
return $ return $
|
||||
objMap (Prim.translate (x,y)) (Prim.translate (x,y,z)) children
|
||||
|
||||
@ -327,11 +327,11 @@ scale = moduleWithSuite "scale" $ \children -> do
|
||||
|
||||
v <- argument "v"
|
||||
`doc` "vector or scalar to scale by"
|
||||
|
||||
|
||||
let
|
||||
scaleObjs stretch2 stretch3 =
|
||||
objMap (Prim.scale stretch2) (Prim.scale stretch3) children
|
||||
|
||||
|
||||
return $ return $ case v of
|
||||
Left x -> scaleObjs (x,1) (x,1,1)
|
||||
Right (Left (x,y)) -> scaleObjs (x,y) (x,y,1)
|
||||
@ -353,7 +353,7 @@ extrude = moduleWithSuite "linear_extrude" $ \children -> do
|
||||
`doc` "translate according to this funciton as we extrude..."
|
||||
r :: ℝ <- argument "r" `defaultTo` 0
|
||||
`doc` "round the top?"
|
||||
|
||||
|
||||
let
|
||||
heightn = case height of
|
||||
Left h -> h
|
||||
@ -372,11 +372,11 @@ extrude = moduleWithSuite "linear_extrude" $ \children -> do
|
||||
funcify :: (VectorSpace a, Fractional (Scalar a)) => Either a (ℝ -> a) -> ℝ -> a
|
||||
funcify (Left val) h = realToFrac (h/heightn) *^ val
|
||||
funcify (Right f ) h = f h
|
||||
|
||||
|
||||
twist' = fmap funcify twist
|
||||
scale' = fmap funcify scaleArg
|
||||
translate' = fmap funcify translateArg
|
||||
|
||||
|
||||
return $ return $ obj2UpMap (
|
||||
\obj -> case height of
|
||||
Left constHeight | isNothing twist && isNothing scaleArg && isNothing translateArg ->
|
||||
|
@ -172,7 +172,7 @@ getImplicit3 (RotateExtrude totalRotation round translate rotate symbObj) =
|
||||
_ -> False
|
||||
in
|
||||
\(x,y,z) -> minimum $ do
|
||||
|
||||
|
||||
let
|
||||
r = sqrt (x*x + y*y)
|
||||
θ = atan2 y x
|
||||
|
@ -138,12 +138,12 @@ polygonR = PolygonR
|
||||
-- $ Shared Operations
|
||||
|
||||
class Object obj vec | obj -> vec where
|
||||
|
||||
|
||||
-- | Complement an Object
|
||||
complement ::
|
||||
obj -- ^ Object to complement
|
||||
-> obj -- ^ Result
|
||||
|
||||
|
||||
-- | Rounded union
|
||||
unionR ::
|
||||
ℝ -- ^ The radius of rounding
|
||||
@ -161,7 +161,7 @@ class Object obj vec | obj -> vec where
|
||||
ℝ -- ^ The radius of rounding
|
||||
-> [obj] -- ^ Objects to intersect
|
||||
-> obj -- ^ Resulting object
|
||||
|
||||
|
||||
-- | Translate an object by a vector of appropriate dimension.
|
||||
translate ::
|
||||
vec -- ^ Vector to translate by (Also: a is a vector, blah, blah)
|
||||
@ -200,7 +200,7 @@ class Object obj vec | obj -> vec where
|
||||
(vec -> ℝ) -- ^ Implicit function
|
||||
-> (vec, vec) -- ^ Bounding box
|
||||
-> obj -- ^ Resulting object
|
||||
|
||||
|
||||
|
||||
instance Object SymbolicObj2 ℝ2 where
|
||||
translate = Translate2
|
||||
|
54
docgen.hs
54
docgen.hs
@ -17,34 +17,34 @@ isArgument (ArgumentDoc _ _ _) = True
|
||||
isArgument _ = False
|
||||
|
||||
main = do
|
||||
let names = map fst primitives
|
||||
docs <- sequence $ map (getArgParserDocs.($ []).snd) primitives
|
||||
let names = map fst primitives
|
||||
docs <- sequence $ map (getArgParserDocs.($ []).snd) primitives
|
||||
|
||||
forM_ (zip names docs) $ \(moduleName, moduleDocList) -> do
|
||||
let
|
||||
examples = filter isExample moduleDocList
|
||||
arguments = filter isArgument moduleDocList
|
||||
putStrLn moduleName
|
||||
putStrLn (map (const '-') moduleName)
|
||||
putStrLn ""
|
||||
if not $ null examples then putStrLn "**Examples:**\n" else return ()
|
||||
forM_ examples $ \(ExampleDoc example) -> do
|
||||
putStrLn $ " * `" ++ example ++ "`"
|
||||
putStrLn ""
|
||||
putStrLn "**Arguments:**\n"
|
||||
forM_ arguments $ \(ArgumentDoc name posfallback description) ->
|
||||
case (posfallback, description) of
|
||||
(Nothing, "") -> do
|
||||
putStrLn $ " * `" ++ name ++ "`"
|
||||
(Just fallback, "") -> do
|
||||
putStrLn $ " * `" ++ name ++ " = " ++ fallback ++ "`"
|
||||
(Nothing, _) -> do
|
||||
putStrLn $ " * `" ++ name ++ "`"
|
||||
putStrLn $ " " ++ description
|
||||
(Just fallback, _) -> do
|
||||
putStrLn $ " * `" ++ name ++ " = " ++ fallback ++ "`"
|
||||
putStrLn $ " " ++ description
|
||||
putStrLn ""
|
||||
forM_ (zip names docs) $ \(moduleName, moduleDocList) -> do
|
||||
let
|
||||
examples = filter isExample moduleDocList
|
||||
arguments = filter isArgument moduleDocList
|
||||
putStrLn moduleName
|
||||
putStrLn (map (const '-') moduleName)
|
||||
putStrLn ""
|
||||
if not $ null examples then putStrLn "**Examples:**\n" else return ()
|
||||
forM_ examples $ \(ExampleDoc example) -> do
|
||||
putStrLn $ " * `" ++ example ++ "`"
|
||||
putStrLn ""
|
||||
putStrLn "**Arguments:**\n"
|
||||
forM_ arguments $ \(ArgumentDoc name posfallback description) ->
|
||||
case (posfallback, description) of
|
||||
(Nothing, "") -> do
|
||||
putStrLn $ " * `" ++ name ++ "`"
|
||||
(Just fallback, "") -> do
|
||||
putStrLn $ " * `" ++ name ++ " = " ++ fallback ++ "`"
|
||||
(Nothing, _) -> do
|
||||
putStrLn $ " * `" ++ name ++ "`"
|
||||
putStrLn $ " " ++ description
|
||||
(Just fallback, _) -> do
|
||||
putStrLn $ " * `" ++ name ++ " = " ++ fallback ++ "`"
|
||||
putStrLn $ " " ++ description
|
||||
putStrLn ""
|
||||
|
||||
-- | We need a format to extract documentation into
|
||||
data Doc = Doc String [DocPart]
|
||||
|
@ -242,6 +242,6 @@ main = execParser opts >>= run
|
||||
where
|
||||
opts= info (helper <*> extOpenScadOpts)
|
||||
( fullDesc
|
||||
<> progDesc "ImplicitCAD: Extended OpenSCAD interpreter."
|
||||
<> progDesc "ImplicitCAD: Extended OpenSCAD interpreter."
|
||||
<> header "extopenscad - Extended OpenSCAD"
|
||||
)
|
||||
|
@ -39,7 +39,7 @@ call name args stmts = StatementI 1 (ModuleCall name args stmts)
|
||||
-- test a simple if block.
|
||||
ifSpec :: Spec
|
||||
ifSpec = it "parses" $
|
||||
"if (true) { a(); } else { b(); }" -->
|
||||
"if (true) { a(); } else { b(); }" -->
|
||||
single ( If (bool True) [call "a" [] []] [call "b" [] []])
|
||||
|
||||
-- test assignments.
|
||||
@ -71,9 +71,9 @@ statementSpec = do
|
||||
describe "empty file" $
|
||||
it "returns an empty list" $
|
||||
emptyFileIssue $ "" --> []
|
||||
describe "line comment" $
|
||||
describe "line comment" $
|
||||
it "parses as empty" $ emptyFileIssue $ "// foish bar\n" --> []
|
||||
describe "module call" $
|
||||
describe "module call" $
|
||||
it "parses" $ "foo();" --> single (ModuleCall "foo" [] [])
|
||||
describe "difference of two cylinders" $
|
||||
it "parses correctly" $
|
||||
|
Loading…
Reference in New Issue
Block a user