implicit 0.0.3 → 0.0.4
raw patch · 45 files changed
+3324/−3326 lines, 45 filesdep +NumInstancesdep ~basedep ~optparse-applicativenew-uploader
Dependencies added: NumInstances
Dependency ranges changed: base, optparse-applicative
Files
- Graphics/Implicit.hs +35/−35
- Graphics/Implicit/Definitions.hs +78/−77
- Graphics/Implicit/Export.hs +67/−66
- Graphics/Implicit/Export/Definitions.hs +1/−1
- Graphics/Implicit/Export/MarchingSquares.hs +153/−153
- Graphics/Implicit/Export/MarchingSquaresFill.hs +86/−86
- Graphics/Implicit/Export/NormedTriangleMeshFormats.hs +27/−27
- Graphics/Implicit/Export/PolylineFormats.hs +2/−4
- Graphics/Implicit/Export/RayTrace.hs +141/−141
- Graphics/Implicit/Export/Render.hs +140/−140
- Graphics/Implicit/Export/Render/Definitions.hs +2/−2
- Graphics/Implicit/Export/Render/GetLoops.hs +13/−13
- Graphics/Implicit/Export/Render/GetSegs.hs +65/−65
- Graphics/Implicit/Export/Render/HandlePolylines.hs +45/−45
- Graphics/Implicit/Export/Render/HandleSquares.hs +58/−58
- Graphics/Implicit/Export/Render/Interpolate.hs +73/−73
- Graphics/Implicit/Export/Render/RefineSegs.hs +37/−37
- Graphics/Implicit/Export/Render/TesselateLoops.hs +43/−43
- Graphics/Implicit/Export/Symbolic/Rebound2.hs +5/−5
- Graphics/Implicit/Export/Symbolic/Rebound3.hs +5/−5
- Graphics/Implicit/Export/SymbolicFormats.hs +4/−2
- Graphics/Implicit/Export/SymbolicObj2.hs +23/−23
- Graphics/Implicit/Export/SymbolicObj3.hs +167/−166
- Graphics/Implicit/Export/TextBuilderUtils.hs +1/−1
- Graphics/Implicit/Export/Util.hs +70/−70
- Graphics/Implicit/ExtOpenScad.hs +13/−13
- Graphics/Implicit/ExtOpenScad/Default.hs +166/−166
- Graphics/Implicit/ExtOpenScad/Definitions.hs +25/−26
- Graphics/Implicit/ExtOpenScad/Eval/Expr.hs +43/−43
- Graphics/Implicit/ExtOpenScad/Eval/Statement.hs +92/−92
- Graphics/Implicit/ExtOpenScad/Parser/Expr.hs +197/−226
- Graphics/Implicit/ExtOpenScad/Parser/Statement.hs +161/−205
- Graphics/Implicit/ExtOpenScad/Parser/Util.hs +57/−35
- Graphics/Implicit/ExtOpenScad/Primitives.hs +350/−347
- Graphics/Implicit/ExtOpenScad/Util/ArgParser.hs +79/−67
- Graphics/Implicit/ExtOpenScad/Util/OVal.hs +73/−74
- Graphics/Implicit/ExtOpenScad/Util/StateC.hs +18/−18
- Graphics/Implicit/MathUtil.hs +70/−70
- Graphics/Implicit/ObjectUtil/GetBox2.hs +57/−57
- Graphics/Implicit/ObjectUtil/GetBox3.hs +108/−103
- Graphics/Implicit/ObjectUtil/GetImplicit2.hs +60/−60
- Graphics/Implicit/ObjectUtil/GetImplicit3.hs +145/−130
- Graphics/Implicit/Primitives.hs +137/−118
- extopenscad.hs +127/−134
- implicit.cabal +5/−4
Graphics/Implicit.hs view
@@ -7,41 +7,41 @@ functionality we want to be accessible to the end user. -} module Graphics.Implicit(- -- Operations- translate,- scale,- complement,- union, intersect, difference,- unionR, intersectR, differenceR,- shell,- --slice,- extrudeR,- extrudeOnEdgeOf,- -- Primitives- sphere,- rect3R,- circle,- cylinder,- cylinder2,- rectR,- --regularPolygon,- --zsurface,- polygon,- -- Export- writeSVG,- writeSTL,- writeBinSTL,- writeOBJ,- writeTHREEJS,- writeSCAD2,- writeSCAD3,- writeGCodeHacklabLaser,- writePNG2,- writePNG3,- runOpenscad,- implicit,- SymbolicObj2,- SymbolicObj3+ -- Operations+ translate,+ scale,+ complement,+ union, intersect, difference,+ unionR, intersectR, differenceR,+ shell,+ --slice,+ extrudeR,+ extrudeOnEdgeOf,+ -- Primitives+ sphere,+ rect3R,+ circle,+ cylinder,+ cylinder2,+ rectR,+ --regularPolygon,+ --zsurface,+ polygon,+ -- Export+ writeSVG,+ writeSTL,+ writeBinSTL,+ writeOBJ,+ writeTHREEJS,+ writeSCAD2,+ writeSCAD3,+ writeGCodeHacklabLaser,+ writePNG2,+ writePNG3,+ runOpenscad,+ implicit,+ SymbolicObj2,+ SymbolicObj3 ) where -- Let's be explicit about where things come from :)
Graphics/Implicit/Definitions.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, OverlappingInstances #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU GPL, see LICENSE@@ -10,7 +10,6 @@ import Data.IORef (IORef, newIORef, readIORef) import System.IO.Unsafe (unsafePerformIO) import Data.VectorSpace -import Control.Applicative -- Let's make things a bit nicer. -- Following math notation ℝ, ℝ², ℝ³...@@ -91,65 +90,68 @@ -- accelerate rendering & give ideal meshes for simple -- cases. data SymbolicObj2 =- -- Primitives- RectR ℝ ℝ2 ℝ2- | Circle ℝ- | PolygonR ℝ [ℝ2]- -- (Rounded) CSG- | Complement2 SymbolicObj2- | UnionR2 ℝ [SymbolicObj2]- | DifferenceR2 ℝ [SymbolicObj2]- | IntersectR2 ℝ [SymbolicObj2]- -- Simple transforms- | Translate2 ℝ2 SymbolicObj2- | Scale2 ℝ2 SymbolicObj2- | Rotate2 ℝ SymbolicObj2- -- Boundary mods- | Outset2 ℝ SymbolicObj2- | Shell2 ℝ SymbolicObj2- -- Misc- | EmbedBoxedObj2 BoxedObj2- deriving Show+ -- Primitives+ RectR ℝ ℝ2 ℝ2+ | Circle ℝ+ | PolygonR ℝ [ℝ2]+ -- (Rounded) CSG+ | Complement2 SymbolicObj2+ | UnionR2 ℝ [SymbolicObj2]+ | DifferenceR2 ℝ [SymbolicObj2]+ | IntersectR2 ℝ [SymbolicObj2]+ -- Simple transforms+ | Translate2 ℝ2 SymbolicObj2+ | Scale2 ℝ2 SymbolicObj2+ | Rotate2 ℝ SymbolicObj2+ | Mirror2 ℝ SymbolicObj2+ -- Boundary mods+ | Outset2 ℝ SymbolicObj2+ | Shell2 ℝ SymbolicObj2+ -- Misc+ | EmbedBoxedObj2 BoxedObj2+ deriving Show -- | A symbolic 3D format! data SymbolicObj3 = - -- Primitives- Rect3R ℝ ℝ3 ℝ3- | Sphere ℝ- | Cylinder ℝ ℝ ℝ -- h r1 r2- -- (Rounded) CSG- | Complement3 SymbolicObj3- | UnionR3 ℝ [SymbolicObj3]- | IntersectR3 ℝ [SymbolicObj3]- | DifferenceR3 ℝ [SymbolicObj3]- -- Simple transforms- | Translate3 ℝ3 SymbolicObj3- | Scale3 ℝ3 SymbolicObj3- | Rotate3 (ℝ,ℝ,ℝ) SymbolicObj3- | Rotate3V ℝ ℝ3 SymbolicObj3- -- Boundary mods- | Outset3 ℝ SymbolicObj3- | Shell3 ℝ SymbolicObj3- -- Misc- | EmbedBoxedObj3 BoxedObj3- -- 2D based- | ExtrudeR ℝ SymbolicObj2 ℝ- | ExtrudeRotateR ℝ ℝ SymbolicObj2 ℝ- | ExtrudeRM - ℝ -- rounding radius- (Maybe (ℝ -> ℝ)) -- twist- (Maybe (ℝ -> ℝ)) -- scale- (Maybe (ℝ -> ℝ2)) -- ranslate- SymbolicObj2 -- object to extrude- (Either ℝ (ℝ2 -> ℝ)) -- height to extrude to- | RotateExtrude- ℝ -- Angle to sweep to- (Maybe ℝ) -- Loop or path (rounded corner)- (Either ℝ2 (ℝ -> ℝ2)) -- translate function- SymbolicObj2 -- object to extrude- | ExtrudeOnEdgeOf SymbolicObj2 SymbolicObj2- deriving Show+ -- Primitives+ Rect3R ℝ ℝ3 ℝ3+ | Sphere ℝ+ | Cylinder ℝ ℝ ℝ -- h r1 r2+ -- (Rounded) CSG+ | Complement3 SymbolicObj3+ | UnionR3 ℝ [SymbolicObj3]+ | IntersectR3 ℝ [SymbolicObj3]+ | DifferenceR3 ℝ [SymbolicObj3]+ -- Simple transforms+ | Translate3 ℝ3 SymbolicObj3+ | Scale3 ℝ3 SymbolicObj3+ | Rotate3 (ℝ,ℝ,ℝ) SymbolicObj3+ | Rotate3V ℝ ℝ3 SymbolicObj3+ | Mirror3 (ℝ,ℝ,ℝ) SymbolicObj3+ -- Boundary mods+ | Outset3 ℝ SymbolicObj3+ | Shell3 ℝ SymbolicObj3+ -- Misc+ | EmbedBoxedObj3 BoxedObj3+ -- 2D based+ | ExtrudeR ℝ SymbolicObj2 ℝ+ | ExtrudeRotateR ℝ ℝ SymbolicObj2 ℝ+ | ExtrudeRM + ℝ -- rounding radius+ (Maybe (ℝ -> ℝ)) -- twist+ (Maybe (ℝ -> ℝ)) -- scale+ (Maybe (ℝ -> ℝ2)) -- translate+ SymbolicObj2 -- object to extrude+ (Either ℝ (ℝ2 -> ℝ)) -- height to extrude to+ | RotateExtrude+ ℝ -- Angle to sweep to+ (Maybe ℝ) -- Loop or path (rounded corner)+ (Either ℝ2 (ℝ -> ℝ2)) -- translate function+ (Either ℝ (ℝ -> ℝ )) -- rotate function+ SymbolicObj2 -- object to extrude+ | ExtrudeOnEdgeOf SymbolicObj2 SymbolicObj2+ deriving Show -- | Rectilinear 2D set type Rectilinear2 = [Box2]@@ -157,11 +159,6 @@ -- | Rectilinear 2D set type Rectilinear3 = [Box3] --- | Make ALL the functions Showable!--- This is very handy when testing functions in interactive mode...-instance Show (a -> b) where- show f = "<function>"- -- | Now for something that makes me a bad person... -- I promise I'll use it for good, not evil! -- I don't want to reparse the program arguments @@ -174,18 +171,22 @@ errorMessage :: Int -> String -> IO() errorMessage line msg = do- useXML <- readIORef xmlErrorOn- let- msg' = "At line <line>" ++ show line ++ "</line>:" ++ msg- -- dropXML inTag (x:xs)- dropXML inQuote False ('"':xs) = '"':dropXML (not inQuote) False xs- dropXML True _ ( x :xs) = x:dropXML True False xs- dropXML False False ('<':xs) = dropXML False True xs- dropXML False True ('>':xs) = dropXML False False xs- dropXML inQuote True ( _ :xs) = dropXML inQuote True xs- dropXML inQuote False ( x :xs) = x:dropXML inQuote False xs- dropXML _ _ [] = []- if useXML - then putStrLn $ "<error>" ++ msg' ++ "</error>"- else putStrLn $ dropXML False False $ msg'- return ()+ useXML <- readIORef xmlErrorOn+ let+ msg' = "At line <line>" ++ show line ++ "</line>:" ++ msg+ -- dropXML inTag (x:xs)+ dropXML inQuote False ('"':xs) = '"':dropXML (not inQuote) False xs+ dropXML True _ ( x :xs) = x:dropXML True False xs+ dropXML False False ('<':xs) = dropXML False True xs+ dropXML False True ('>':xs) = dropXML False False xs+ dropXML inQuote True ( _ :xs) = dropXML inQuote True xs+ dropXML inQuote False ( x :xs) = x:dropXML inQuote False xs+ dropXML _ _ [] = []+ putStrLn $ if useXML + then "<error>" ++ msg' ++ "</error>"+ else dropXML False False msg'+ return ()++-- HACK: This needs to be fixed correctly someday+instance Show (a -> b) where+ show _ = "<function>"
Graphics/Implicit/Export.hs view
@@ -1,5 +1,6 @@ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU GPL, see LICENSE+{-# LANGUAGE FlexibleContexts #-} module Graphics.Implicit.Export where @@ -46,10 +47,10 @@ -> IO () -- ^ Writing Action! writeObject' res formatWriter filename obj =- let- aprox = discreteAprox res obj- in - formatWriter filename aprox+ let+ aprox = discreteAprox res obj+ in + formatWriter filename aprox formatObject :: (DiscreteAproxable obj aprox) => ℝ -- ^ Resolution@@ -78,75 +79,75 @@ {- renderRaw :: ℝ3 -> ℝ3 -> ℝ -> String -> Obj3 -> IO() renderRaw (x1, y1, z1) (x2, y2, z2) res name obj = - -- A hacky way to encode to chars, but it will do- let convert n = if n > 1 then 'a' else if n > 0.5 then 'b' else if n > 0.1 then 'c' else if n == 0 then 'd' else if n > -0.5 then 'e' else 'd' in- do- putStrLn $ show $ length $ [ obj (x,y,z) | x <- [x1, x1+res.. x2], y <- [y1, y1+res.. y2], z <- [z1, z1+res.. z2] ]- out <- openFile name WriteMode- mapM_ ( (hPutChar out) . convert) $ - [ obj (x,y,z) | x <- [x1, x1+res.. x2], y <- [y1, y1+res.. y2], z <- [z1, z1+res.. z2] ]- hClose out+ -- A hacky way to encode to chars, but it will do+ let convert n = if n > 1 then 'a' else if n > 0.5 then 'b' else if n > 0.1 then 'c' else if n == 0 then 'd' else if n > -0.5 then 'e' else 'd' in+ do+ putStrLn $ show $ length $ [ obj (x,y,z) | x <- [x1, x1+res.. x2], y <- [y1, y1+res.. y2], z <- [z1, z1+res.. z2] ]+ out <- openFile name WriteMode+ mapM_ ( (hPutChar out) . convert) $ + [ obj (x,y,z) | x <- [x1, x1+res.. x2], y <- [y1, y1+res.. y2], z <- [z1, z1+res.. z2] ]+ hClose out renderRaw2D :: ℝ2 -> ℝ2 -> ℝ -> String -> Obj2 -> IO() renderRaw2D (x1, y1) (x2, y2) res name obj = - -- A hacky way to encode to chars, but it will do- let convert n = if n > 1 then 'a' else if n > 0.5 then 'b' else if n > 0.1 then 'c' else if n == 0 then 'd' else if n > -0.5 then 'e' else 'd' in- do- putStrLn $ show $ length $ [x1, x1+res.. x2]- putStrLn $ show $ length $ [ obj (x,y) | x <- [x1, x1+res.. x2], y <- [y1, y1+res.. y2] ]- out <- openFile name WriteMode- mapM_ (mapM_ ( (hPutChar out) . convert)) $ - [[ obj (x,y) | x <- [x1, x1+res.. x2] ] | y <- [y1, y1+res.. y2] ]- hClose out+ -- A hacky way to encode to chars, but it will do+ let convert n = if n > 1 then 'a' else if n > 0.5 then 'b' else if n > 0.1 then 'c' else if n == 0 then 'd' else if n > -0.5 then 'e' else 'd' in+ do+ putStrLn $ show $ length $ [x1, x1+res.. x2]+ putStrLn $ show $ length $ [ obj (x,y) | x <- [x1, x1+res.. x2], y <- [y1, y1+res.. y2] ]+ out <- openFile name WriteMode+ mapM_ (mapM_ ( (hPutChar out) . convert)) $ + [[ obj (x,y) | x <- [x1, x1+res.. x2] ] | y <- [y1, y1+res.. y2] ]+ hClose out {-writeGCodeMakerbot :: - ℝ3 -- ^ lower corner of bounding box- -> ℝ3 -- ^ upper corner of bounding box- -> ℝ -- ^ resolution of rendering- -> FilePath -- ^ Filename to write gcode to- -> Obj3 -- ^ 3D object to make gcode for- -> IO () -- ^ Resulting IO action that will write gcode+ ℝ3 -- ^ lower corner of bounding box+ -> ℝ3 -- ^ upper corner of bounding box+ -> ℝ -- ^ resolution of rendering+ -> FilePath -- ^ Filename to write gcode to+ -> Obj3 -- ^ 3D object to make gcode for+ -> IO () -- ^ Resulting IO action that will write gcode writeGCodeMakerbot (x1,y1,z1) (x2,y2,z2) d name obj = - let - slices = [slice zheight obj | zheight <- [z1, z1+0.1.. z2] ]- prep obj (x,y) = (obj (x,y), obj (x+d,y), obj (x+d,y+d), obj (x,y+d), obj (x+d/2,y+d/2) , (x,y), d ) - layer obj2 = (filter polylineNotNull) $ (map reducePolyline) $ orderLines $ concat $ map getLineSeg [prep obj2 (x,y) | x <- [x1, x1+d.. x2], y <- [y1, y1 +d.. y2] ]- levelmultilines = map layer slices- gcodeHeader = - "(generated by ImplicitCAD, based of skeinforge default makerbot results)\n"- ++ "(**** Initialization ****)\n"- ++ "M104 S220 T0 (Temperature to 220 celsius)\n"- ++ "M109 S110 T0 (set heated-build-platform temperature)\n"- ++ "G21 (Metric FTW)\n"- ++ "G90 (Absolute Positioning)\n"- ++ "G92 X0 Y0 Z0 (You are now at 0,0,0)\n"- ++ "M108 S255 (Extruder speed = max; not turning it on yet!)\n"- ++ "(**** Prep the extruder... ****)\n"- ++ "G0 Z15 (Move up for test extrusion)\n"- ++ "M6 T0 (Wait for tool to heat up)\n"- ++ "G04 P5000 (Wait 5 seconds)\n"- ++ "M101 (Extruder on, forward)\n"- ++ "G04 P5000 (Wait 5 seconds)\n"- ++ "M103 (Extruder off)\n"- ++ "M01 (The heater is warming up and will do a test extrusion. Click yes after you have cleared the nozzle of the extrusion.)\n"- ++ "G0 Z0(Go back to zero.)\n"- gcodeFooter = - "M104 S0 (extruder heating off!)\n"- ++"G00 X0.0 Y0.0 (move to 0)\n"- ++"M2 (end)"- gcodeXYZ :: ℝ3 -> [Char]- gcodeXYZ (x,y,z) = "X"++ show x ++" Y"++ show y ++" Z"++ show z- interpretPolyline (start:others) = - "G00 "++ gcodeXY start ++ "\n"- ++ "M101 (extruder forward!)\n"- ++ concat (map (\p -> "G01 " ++ (gcodeXY p) ++ "\n") others)- ++ "M103 (extruder off)\n\n"- text = gcodeHeader- ++ (concat $ map interpretPolyline multilines)- ++ gcodeFooter- in do - writeFile name text+ let + slices = [slice zheight obj | zheight <- [z1, z1+0.1.. z2] ]+ prep obj (x,y) = (obj (x,y), obj (x+d,y), obj (x+d,y+d), obj (x,y+d), obj (x+d/2,y+d/2) , (x,y), d ) + layer obj2 = (filter polylineNotNull) $ (map reducePolyline) $ orderLines $ concat $ map getLineSeg [prep obj2 (x,y) | x <- [x1, x1+d.. x2], y <- [y1, y1 +d.. y2] ]+ levelmultilines = map layer slices+ gcodeHeader = + "(generated by ImplicitCAD, based of skeinforge default makerbot results)\n"+ ++ "(**** Initialization ****)\n"+ ++ "M104 S220 T0 (Temperature to 220 celsius)\n"+ ++ "M109 S110 T0 (set heated-build-platform temperature)\n"+ ++ "G21 (Metric FTW)\n"+ ++ "G90 (Absolute Positioning)\n"+ ++ "G92 X0 Y0 Z0 (You are now at 0,0,0)\n"+ ++ "M108 S255 (Extruder speed = max; not turning it on yet!)\n"+ ++ "(**** Prep the extruder... ****)\n"+ ++ "G0 Z15 (Move up for test extrusion)\n"+ ++ "M6 T0 (Wait for tool to heat up)\n"+ ++ "G04 P5000 (Wait 5 seconds)\n"+ ++ "M101 (Extruder on, forward)\n"+ ++ "G04 P5000 (Wait 5 seconds)\n"+ ++ "M103 (Extruder off)\n"+ ++ "M01 (The heater is warming up and will do a test extrusion. Click yes after you have cleared the nozzle of the extrusion.)\n"+ ++ "G0 Z0(Go back to zero.)\n"+ gcodeFooter = + "M104 S0 (extruder heating off!)\n"+ ++"G00 X0.0 Y0.0 (move to 0)\n"+ ++"M2 (end)"+ gcodeXYZ :: ℝ3 -> [Char]+ gcodeXYZ (x,y,z) = "X"++ show x ++" Y"++ show y ++" Z"++ show z+ interpretPolyline (start:others) = + "G00 "++ gcodeXY start ++ "\n"+ ++ "M101 (extruder forward!)\n"+ ++ concat (map (\p -> "G01 " ++ (gcodeXY p) ++ "\n") others)+ ++ "M103 (extruder off)\n\n"+ text = gcodeHeader+ ++ (concat $ map interpretPolyline multilines)+ ++ gcodeFooter+ in do + writeFile name text -} -}
Graphics/Implicit/Export/Definitions.hs view
@@ -9,6 +9,6 @@ -- eg. Aproximating a 3D object with a tirangle mesh -- would be DiscreteApproxable Obj3 TriangleMesh class DiscreteAproxable obj aprox where- discreteAprox :: ℝ -> obj -> aprox+ discreteAprox :: ℝ -> obj -> aprox
Graphics/Implicit/Export/MarchingSquares.hs view
@@ -17,51 +17,51 @@ getContour :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [Polyline] getContour p1 p2 d obj =- let- -- How many steps will we take on each axis?- n@(nx,ny) = (fromIntegral . ceiling) `both` ((p2 ^-^ p1) ⋯/ d)- -- Divide it up and compute the polylines- gridPos :: (Int,Int) -> (Int,Int) -> ℝ2- gridPos (nx,ny) (mx,my) = let p = ( fromIntegral mx / fromIntegral nx- , fromIntegral my / fromIntegral ny)- in p1 ^+^ (p2 ^-^ p1) ⋯* p- linesOnGrid :: [[[Polyline]]]- linesOnGrid = [[getSquareLineSegs- (gridPos n (mx,my))- (gridPos n (mx+1,my+1))- obj- | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]- -- Cleanup, cleanup, everybody cleanup!- -- (We connect multilines, delete redundant vertices on them, etc)- multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLinesDC $ linesOnGrid- in- multilines+ let+ -- How many steps will we take on each axis?+ n@(nx,ny) = (fromIntegral . ceiling) `both` ((p2 ^-^ p1) ⋯/ d)+ -- Divide it up and compute the polylines+ gridPos :: (Int,Int) -> (Int,Int) -> ℝ2+ gridPos (nx,ny) (mx,my) = let p = ( fromIntegral mx / fromIntegral nx+ , fromIntegral my / fromIntegral ny)+ in p1 ^+^ (p2 ^-^ p1) ⋯* p+ linesOnGrid :: [[[Polyline]]]+ linesOnGrid = [[getSquareLineSegs+ (gridPos n (mx,my))+ (gridPos n (mx+1,my+1))+ obj+ | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]+ -- Cleanup, cleanup, everybody cleanup!+ -- (We connect multilines, delete redundant vertices on them, etc)+ multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLinesDC $ linesOnGrid+ in+ multilines getContour2 :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [Polyline] getContour2 p1@(x1, y1) p2@(x2, y2) d obj = - let- -- How many steps will we take on each axis?- n@(nx,ny) = (fromIntegral . ceiling) `both` ((p2 ^-^ p1) ⋯/ d)- -- Grid mapping funcs- fromGrid (mx, my) = let p = (mx/nx, my/ny)- in (p1 ^+^ (p2 ^-^ p1) ⋯/ p)- toGrid (x,y) = (floor $ nx*(x-x1)/(x2-x1), floor $ ny*(y-y1)/(y2-y1))- -- Evaluate obj on a grid, in parallel.- valsOnGrid :: [[ℝ]]- valsOnGrid = [[ obj (fromGrid (mx, my)) | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]- `using` parList rdeepseq- -- A faster version of the obj. Sort of like memoization, but done in advance, in parallel.- preEvaledObj p = valsOnGrid !! my !! mx where (mx,my) = toGrid p- -- Divide it up and compute the polylines- linesOnGrid :: [[[Polyline]]]- linesOnGrid = [[getSquareLineSegs (fromGrid (mx, my)) (fromGrid (mx+1, my+1)) preEvaledObj- | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]- -- Cleanup, cleanup, everybody cleanup!- -- (We connect multilines, delete redundant vertices on them, etc)- multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLinesDC $ linesOnGrid- in- multilines- + let+ -- How many steps will we take on each axis?+ n@(nx,ny) = (fromIntegral . ceiling) `both` ((p2 ^-^ p1) ⋯/ d)+ -- Grid mapping funcs+ fromGrid (mx, my) = let p = (mx/nx, my/ny)+ in (p1 ^+^ (p2 ^-^ p1) ⋯/ p)+ toGrid (x,y) = (floor $ nx*(x-x1)/(x2-x1), floor $ ny*(y-y1)/(y2-y1))+ -- Evaluate obj on a grid, in parallel.+ valsOnGrid :: [[ℝ]]+ valsOnGrid = [[ obj (fromGrid (mx, my)) | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]+ `using` parList rdeepseq+ -- A faster version of the obj. Sort of like memoization, but done in advance, in parallel.+ preEvaledObj p = valsOnGrid !! my !! mx where (mx,my) = toGrid p+ -- Divide it up and compute the polylines+ linesOnGrid :: [[[Polyline]]]+ linesOnGrid = [[getSquareLineSegs (fromGrid (mx, my)) (fromGrid (mx+1, my+1)) preEvaledObj+ | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]+ -- Cleanup, cleanup, everybody cleanup!+ -- (We connect multilines, delete redundant vertices on them, etc)+ multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLinesDC $ linesOnGrid+ in+ multilines+ -- | This function gives line segments to divide negative interior -- regions and positive exterior ones inside a square, based on its @@ -70,77 +70,77 @@ getSquareLineSegs :: ℝ2 -> ℝ2 -> Obj2 -> [Polyline] getSquareLineSegs p1@(x1, y1) p2@(x2, y2) obj =- let - (x,y) = (x1, y1)+ let + (x,y) = (x1, y1) - -- Let's evlauate obj at a few points...- x1y1 = obj (x1, y1)- x2y1 = obj (x2, y1)- x1y2 = obj (x1, y2)- x2y2 = obj (x2, y2)- c = obj ((x1+x2)/2, (y1+y2)/2)+ -- Let's evlauate obj at a few points...+ x1y1 = obj (x1, y1)+ x2y1 = obj (x2, y1)+ x1y2 = obj (x1, y2)+ x2y2 = obj (x2, y2)+ c = obj ((x1+x2)/2, (y1+y2)/2) - dx = x2 - x1- dy = y2 - y1+ dx = x2 - x1+ dy = y2 - y1 - -- linearly interpolated midpoints on the relevant axis- -- midy2- -- _________*__________- -- | |- -- | |- -- | |- --midx1* * midx2- -- | |- -- | |- -- | |- -- -----------*----------- -- midy1+ -- linearly interpolated midpoints on the relevant axis+ -- midy2+ -- _________*__________+ -- | |+ -- | |+ -- | |+ --midx1* * midx2+ -- | |+ -- | |+ -- | |+ -- -----------*----------+ -- midy1 - midx1 = (x, y + dy*x1y1/(x1y1-x1y2))- midx2 = (x + dx, y + dy*x2y1/(x2y1-x2y2))- midy1 = (x + dx*x1y1/(x1y1-x2y1), y )- midy2 = (x + dx*x1y2/(x1y2-x2y2), y + dy)- notPointLine (p1:p2:[]) = p1 /= p2- in filter (notPointLine) $ case (x1y2 <= 0, x2y2 <= 0,- x1y1 <= 0, x2y1 <= 0) of- -- Yes, there's some symetries that could reduce the amount of code...- -- But I don't think they're worth exploiting...- (True, True, - True, True) -> []- (False, False,- False, False) -> []- (True, True, - False, False) -> [[midx1, midx2]]- (False, False,- True, True) -> [[midx1, midx2]]- (False, True, - False, True) -> [[midy1, midy2]]- (True, False,- True, False) -> [[midy1, midy2]]- (True, False,- False, False) -> [[midx1, midy2]]- (False, True, - True, True) -> [[midx1, midy2]]- (True, True, - False, True) -> [[midx1, midy1]]- (False, False,- True, False) -> [[midx1, midy1]]- (True, True, - True, False) -> [[midx2, midy1]]- (False, False,- False, True) -> [[midx2, midy1]]- (True, False,- True, True) -> [[midx2, midy2]]- (False, True, - False, False) -> [[midx2, midy2]]- (True, False,- False, True) -> if c > 0- then [[midx1, midy2], [midx2, midy1]]- else [[midx1, midy1], [midx2, midy2]]- (False, True, - True, False) -> if c <= 0- then [[midx1, midy2], [midx2, midy1]]- else [[midx1, midy1], [midx2, midy2]]+ midx1 = (x, y + dy*x1y1/(x1y1-x1y2))+ midx2 = (x + dx, y + dy*x2y1/(x2y1-x2y2))+ midy1 = (x + dx*x1y1/(x1y1-x2y1), y )+ midy2 = (x + dx*x1y2/(x1y2-x2y2), y + dy)+ notPointLine (p1:p2:[]) = p1 /= p2+ in filter (notPointLine) $ case (x1y2 <= 0, x2y2 <= 0,+ x1y1 <= 0, x2y1 <= 0) of+ -- Yes, there's some symetries that could reduce the amount of code...+ -- But I don't think they're worth exploiting...+ (True, True, + True, True) -> []+ (False, False,+ False, False) -> []+ (True, True, + False, False) -> [[midx1, midx2]]+ (False, False,+ True, True) -> [[midx1, midx2]]+ (False, True, + False, True) -> [[midy1, midy2]]+ (True, False,+ True, False) -> [[midy1, midy2]]+ (True, False,+ False, False) -> [[midx1, midy2]]+ (False, True, + True, True) -> [[midx1, midy2]]+ (True, True, + False, True) -> [[midx1, midy1]]+ (False, False,+ True, False) -> [[midx1, midy1]]+ (True, True, + True, False) -> [[midx2, midy1]]+ (False, False,+ False, True) -> [[midx2, midy1]]+ (True, False,+ True, True) -> [[midx2, midy2]]+ (False, True, + False, False) -> [[midx2, midy2]]+ (True, False,+ False, True) -> if c > 0+ then [[midx1, midy2], [midx2, midy1]]+ else [[midx1, midy1], [midx2, midy2]]+ (False, True, + True, False) -> if c <= 0+ then [[midx1, midy2], [midx2, midy1]]+ else [[midx1, midy1], [midx2, midy2]] @@ -152,62 +152,62 @@ orderLines :: [Polyline] -> [Polyline] orderLines [] = [] orderLines (present:remaining) =- let- findNext ((p3:ps):segs) = if p3 == last present then (Just (p3:ps), segs) else- if last ps == last present then (Just (reverse $ p3:ps), segs) else- case findNext segs of (res1,res2) -> (res1,(p3:ps):res2)- findNext [] = (Nothing, [])- in- case findNext remaining of- (Nothing, _) -> present:(orderLines remaining)- (Just match, others) -> orderLines $ (present ++ tail match): others+ let+ findNext ((p3:ps):segs) = if p3 == last present then (Just (p3:ps), segs) else+ if last ps == last present then (Just (reverse $ p3:ps), segs) else+ case findNext segs of (res1,res2) -> (res1,(p3:ps):res2)+ findNext [] = (Nothing, [])+ in+ case findNext remaining of+ (Nothing, _) -> present:(orderLines remaining)+ (Just match, others) -> orderLines $ (present ++ tail match): others reducePolyline ((x1,y1):(x2,y2):(x3,y3):others) = - if (x1,y1) == (x2,y2) then reducePolyline ((x2,y2):(x3,y3):others) else- if abs ( (y2-y1)/(x2-x1) - (y3-y1)/(x3-x1) ) < 0.0001 - || ( (x2-x1) == 0 && (x3-x1) == 0 && (y2-y1)*(y3-y1) > 0)- then reducePolyline ((x1,y1):(x3,y3):others)- else (x1,y1) : reducePolyline ((x2,y2):(x3,y3):others)+ if (x1,y1) == (x2,y2) then reducePolyline ((x2,y2):(x3,y3):others) else+ if abs ( (y2-y1)/(x2-x1) - (y3-y1)/(x3-x1) ) < 0.0001 + || ( (x2-x1) == 0 && (x3-x1) == 0 && (y2-y1)*(y3-y1) > 0)+ then reducePolyline ((x1,y1):(x3,y3):others)+ else (x1,y1) : reducePolyline ((x2,y2):(x3,y3):others) reducePolyline ((x1,y1):(x2,y2):others) = - if (x1,y1) == (x2,y2) then reducePolyline ((x2,y2):others) else (x1,y1):(x2,y2):others+ if (x1,y1) == (x2,y2) then reducePolyline ((x2,y2):others) else (x1,y1):(x2,y2):others reducePolyline l = l orderLinesDC :: [[[Polyline]]] -> [Polyline] orderLinesDC segs =- let- halve :: [a] -> ([a], [a])- halve l = splitAt (div (length l) 2) l- splitOrder segs = case (\(x,y) -> (halve x, halve y)) . unzip . map (halve) $ segs of- ((a,b),(c,d)) -> orderLinesDC a ++ orderLinesDC b ++ orderLinesDC c ++ orderLinesDC d- in- if (length segs < 5 || length (head segs) < 5 ) then concat $ concat segs else- case (\(x,y) -> (halve x, halve y)) $ unzip $ map (halve) segs of- ((a,b),(c,d)) ->orderLines $ - orderLinesDC a ++ orderLinesDC b ++ orderLinesDC c ++ orderLinesDC d+ let+ halve :: [a] -> ([a], [a])+ halve l = splitAt (div (length l) 2) l+ splitOrder segs = case (\(x,y) -> (halve x, halve y)) . unzip . map (halve) $ segs of+ ((a,b),(c,d)) -> orderLinesDC a ++ orderLinesDC b ++ orderLinesDC c ++ orderLinesDC d+ in+ if (length segs < 5 || length (head segs) < 5 ) then concat $ concat segs else+ case (\(x,y) -> (halve x, halve y)) $ unzip $ map (halve) segs of+ ((a,b),(c,d)) ->orderLines $ + orderLinesDC a ++ orderLinesDC b ++ orderLinesDC c ++ orderLinesDC d {- orderLinesP :: [[[Polyline]]] -> [Polyline] orderLinesP segs =- let- halve l = splitAt (div (length l) 2) l- splitOrder segs = case (\(x,y) -> (halve x, halve y)) $ unzip $ map (halve) segs of- ((a,b),(c,d)) -> orderLinesDC a ++ orderLinesDC b ++ orderLinesDC c ++ orderLinesDC d- -- force is frome real world haskell- force xs = go xs `pseq` ()- where go (_:xs) = go xs- go [] = 1- in- if (length segs < 5 || length (head segs) < 5 ) then concat $ concat segs else- case (\(x,y) -> (halve x, halve y)) $ unzip $ map (halve) segs of- ((a,b),(c,d)) -> orderLines $ - let- a' = orderLinesP a- b' = orderLinesP b- c' = orderLinesP c- d' = orderLinesP d- in (force a' `par` force b' `par` force c' `par` force d') `pseq` - (a' ++ b' ++ c' ++ d')+ let+ halve l = splitAt (div (length l) 2) l+ splitOrder segs = case (\(x,y) -> (halve x, halve y)) $ unzip $ map (halve) segs of+ ((a,b),(c,d)) -> orderLinesDC a ++ orderLinesDC b ++ orderLinesDC c ++ orderLinesDC d+ -- force is frome real world haskell+ force xs = go xs `pseq` ()+ where go (_:xs) = go xs+ go [] = 1+ in+ if (length segs < 5 || length (head segs) < 5 ) then concat $ concat segs else+ case (\(x,y) -> (halve x, halve y)) $ unzip $ map (halve) segs of+ ((a,b),(c,d)) -> orderLines $ + let+ a' = orderLinesP a+ b' = orderLinesP b+ c' = orderLinesP c+ d' = orderLinesP d+ in (force a' `par` force b' `par` force c' `par` force d') `pseq` + (a' ++ b' ++ c' ++ d') -}
Graphics/Implicit/Export/MarchingSquaresFill.hs view
@@ -12,21 +12,21 @@ getContourMesh :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [(ℝ2,ℝ2,ℝ2)] getContourMesh (x1, y1) (x2, y2) (dx, dy) obj = - let- -- How many steps will we take on each axis?- nx = fromIntegral $ ceiling $ (x2 - x1) / dx- ny = fromIntegral $ ceiling $ (y2 - y1) / dy- -- Divide it up and compute the polylines- trisOnGrid :: [[[(ℝ2,ℝ2,ℝ2)]]]- trisOnGrid = [[getSquareTriangles- (x1 + (x2 - x1)*mx/nx, y1 + (y2 - y1)*my/ny)- (x1 + (x2 - x1)*(mx+1)/nx, y1 + (y2 - y1)*(my+1)/ny)- obj- | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]- triangles = concat $ concat trisOnGrid- in- triangles- + let+ -- How many steps will we take on each axis?+ nx = fromIntegral $ ceiling $ (x2 - x1) / dx+ ny = fromIntegral $ ceiling $ (y2 - y1) / dy+ -- Divide it up and compute the polylines+ trisOnGrid :: [[[(ℝ2,ℝ2,ℝ2)]]]+ trisOnGrid = [[getSquareTriangles+ (x1 + (x2 - x1)*mx/nx, y1 + (y2 - y1)*my/ny)+ (x1 + (x2 - x1)*(mx+1)/nx, y1 + (y2 - y1)*(my+1)/ny)+ obj+ | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]+ triangles = concat $ concat trisOnGrid+ in+ triangles+ -- | This function gives line segmensts to divde negative interior -- regions and positive exterior ones inside a square, based on its @@ -35,83 +35,83 @@ getSquareTriangles :: ℝ2 -> ℝ2 -> Obj2 -> [(ℝ2,ℝ2,ℝ2)] getSquareTriangles (x1, y1) (x2, y2) obj = - let - (x,y) = (x1, y1)+ let + (x,y) = (x1, y1) - -- Let's evlauate obj at a few points...- x1y1 = obj (x1, y1)- x2y1 = obj (x2, y1)- x1y2 = obj (x1, y2)- x2y2 = obj (x2, y2)- c = obj ((x1+x2)/2, (y1+y2)/2)+ -- Let's evlauate obj at a few points...+ x1y1 = obj (x1, y1)+ x2y1 = obj (x2, y1)+ x1y2 = obj (x1, y2)+ x2y2 = obj (x2, y2)+ c = obj ((x1+x2)/2, (y1+y2)/2) - dx = x2 - x1- dy = y2 - y1+ dx = x2 - x1+ dy = y2 - y1 - -- linearly interpolated midpoints on the relevant axis- -- midy2- -- _________*__________- -- | |- -- | |- -- | |- --midx1* * midx2- -- | |- -- | |- -- | |- -- -----------*----------- -- midy1+ -- linearly interpolated midpoints on the relevant axis+ -- midy2+ -- _________*__________+ -- | |+ -- | |+ -- | |+ --midx1* * midx2+ -- | |+ -- | |+ -- | |+ -- -----------*----------+ -- midy1 - midx1 = (x, y + dy*x1y1/(x1y1-x1y2))- midx2 = (x + dx, y + dy*x2y1/(x2y1-x2y2))- midy1 = (x + dx*x1y1/(x1y1-x2y1), y )- midy2 = (x + dx*x1y2/(x1y2-x2y2), y + dy)+ midx1 = (x, y + dy*x1y1/(x1y1-x1y2))+ midx2 = (x + dx, y + dy*x2y1/(x2y1-x2y2))+ midy1 = (x + dx*x1y1/(x1y1-x2y1), y )+ midy2 = (x + dx*x1y2/(x1y2-x2y2), y + dy) - square a b c d = [(a,b,c), (a,c,d)]+ square a b c d = [(a,b,c), (a,c,d)] - in case (x1y2 <= 0, x2y2 <= 0,- x1y1 <= 0, x2y1 <= 0) of- -- Yes, there's some symetries that could reduce the amount of code...- -- But I don't think they're worth exploiting...- (True, True, - True, True) -> square (x1,y1) (x2,y1) (x2,y2) (x1,y2)- (False, False,- False, False) -> []- (True, True, - False, False) -> square midx1 midx2 (x2,y2) (x1,y2) - (False, False,- True, True) -> square (x1,y1) (x2,y1) midx2 midx1 - (False, True, - False, True) -> square midy1 (x2,y1) (x2,y2) midy2- (True, False,- True, False) -> square (x1,y1) midy1 midy2 (x1,y2)- (True, False,- False, False) -> [((x1,y2), midx1, midy2)]- (False, True, - True, True) -> - [(midx1, (x1,y1), midy2), ((x1,y1), (x2,y1), midy2), (midy2, (x2,y1), (x2,y2))]- (True, True, - False, True) -> - [((x1,y2), midx1, (x2,y2)), (midx1, midy1, (x2,y2)), ((x2,y2), midy1, (x2,y1))] - (False, False,- True, False) -> [(midx1, (x1,y1), midy1)]- (True, True, - True, False) -> - [(midy1,midx2,(x2,y2)), ((x2,y2), (x1,y2), midy1), (midy1, (x1,y2), (x1,y1))]- (False, False,- False, True) -> [(midx2, midy1, (x2,y1))]- (True, False,- True, True) -> - [(midy2, (x2,y1), midx2), ((x2,y1), midy2, (x1,y1)), ((x1,y1), midy2, (x1,y2))]- (False, True, - False, False) -> [(midx2, (x2,y2), midy2)]- (True, False,- False, True) -> if c > 0- then [((x1,y2), midx1, midy2), ((x2,y1), midy1, midx2)]- else [] --[[midx1, midy1], [midx2, midy2]]- (False, True, - True, False) -> if c <= 0- then [] --[[midx1, midy2], [midx2, midy1]]- else [((x1,y1), midy1, midx1), ((x2,y2), midx2, midy2)] --[[midx1, midy1], [midx2, midy2]]+ in case (x1y2 <= 0, x2y2 <= 0,+ x1y1 <= 0, x2y1 <= 0) of+ -- Yes, there's some symetries that could reduce the amount of code...+ -- But I don't think they're worth exploiting...+ (True, True, + True, True) -> square (x1,y1) (x2,y1) (x2,y2) (x1,y2)+ (False, False,+ False, False) -> []+ (True, True, + False, False) -> square midx1 midx2 (x2,y2) (x1,y2) + (False, False,+ True, True) -> square (x1,y1) (x2,y1) midx2 midx1 + (False, True, + False, True) -> square midy1 (x2,y1) (x2,y2) midy2+ (True, False,+ True, False) -> square (x1,y1) midy1 midy2 (x1,y2)+ (True, False,+ False, False) -> [((x1,y2), midx1, midy2)]+ (False, True, + True, True) -> + [(midx1, (x1,y1), midy2), ((x1,y1), (x2,y1), midy2), (midy2, (x2,y1), (x2,y2))]+ (True, True, + False, True) -> + [((x1,y2), midx1, (x2,y2)), (midx1, midy1, (x2,y2)), ((x2,y2), midy1, (x2,y1))] + (False, False,+ True, False) -> [(midx1, (x1,y1), midy1)]+ (True, True, + True, False) -> + [(midy1,midx2,(x2,y2)), ((x2,y2), (x1,y2), midy1), (midy1, (x1,y2), (x1,y1))]+ (False, False,+ False, True) -> [(midx2, midy1, (x2,y1))]+ (True, False,+ True, True) -> + [(midy2, (x2,y1), midx2), ((x2,y1), midy2, (x1,y1)), ((x1,y1), midy2, (x1,y2))]+ (False, True, + False, False) -> [(midx2, (x2,y2), midy2)]+ (True, False,+ False, True) -> if c > 0+ then [((x1,y2), midx1, midy2), ((x2,y1), midy1, midx2)]+ else [] --[[midx1, midy1], [midx2, midy2]]+ (False, True, + True, False) -> if c <= 0+ then [] --[[midx1, midy2], [midx2, midy1]]+ else [((x1,y1), midy1, midx1), ((x2,y2), midx2, midy2)] --[[midx1, midy1], [midx2, midy2]]
Graphics/Implicit/Export/NormedTriangleMeshFormats.hs view
@@ -10,31 +10,31 @@ obj normedtriangles = toLazyText $ vertcode <> normcode <> trianglecode- where- -- A vertex line; v (0.0, 0.0, 1.0) = "v 0.0 0.0 1.0\n"- v :: ℝ3 -> Builder- v (x,y,z) = "v " <> bf x <> " " <> bf y <> " " <> bf z <> "\n"- -- A normal line; n (0.0, 0.0, 1.0) = "vn 0.0 0.0 1.0\n"- n :: ℝ3 -> Builder- n (x,y,z) = "vn " <> bf x <> " " <> bf y <> " " <> bf z <> "\n"- verts = do- -- extract the vertices for each triangle- -- recall that a normed triangle is of the form ((vert, norm), ...)- ((a,_),(b,_),(c,_)) <- normedtriangles- -- The vertices from each triangle take up 3 position in the resulting list- [a,b,c]- norms = do- -- extract the normals for each triangle- ((_,a),(_,b),(_,c)) <- normedtriangles- -- The normals from each triangle take up 3 position in the resulting list- [a,b,c]- vertcode = mconcat $ map v verts- normcode = mconcat $ map n norms- trianglecode = mconcat $ do- n <- map ((+1).(*3)) [0,1 .. length normedtriangles -1]- let- vta = buildInt n- vtb = buildInt (n+1)- vtc = buildInt (n+2)- return $ "f " <> vta <> " " <> vtb <> " " <> vtc <> " " <> "\n"+ where+ -- A vertex line; v (0.0, 0.0, 1.0) = "v 0.0 0.0 1.0\n"+ v :: ℝ3 -> Builder+ v (x,y,z) = "v " <> bf x <> " " <> bf y <> " " <> bf z <> "\n"+ -- A normal line; n (0.0, 0.0, 1.0) = "vn 0.0 0.0 1.0\n"+ n :: ℝ3 -> Builder+ n (x,y,z) = "vn " <> bf x <> " " <> bf y <> " " <> bf z <> "\n"+ verts = do+ -- extract the vertices for each triangle+ -- recall that a normed triangle is of the form ((vert, norm), ...)+ ((a,_),(b,_),(c,_)) <- normedtriangles+ -- The vertices from each triangle take up 3 position in the resulting list+ [a,b,c]+ norms = do+ -- extract the normals for each triangle+ ((_,a),(_,b),(_,c)) <- normedtriangles+ -- The normals from each triangle take up 3 position in the resulting list+ [a,b,c]+ vertcode = mconcat $ map v verts+ normcode = mconcat $ map n norms+ trianglecode = mconcat $ do+ n <- map ((+1).(*3)) [0,1 .. length normedtriangles -1]+ let+ vta = buildInt n+ vtb = buildInt (n+1)+ vtc = buildInt (n+2)+ return $ "f " <> vta <> " " <> vtb <> " " <> vtc <> " " <> "\n"
Graphics/Implicit/Export/PolylineFormats.hs view
@@ -15,7 +15,7 @@ import Text.Blaze.Internal (stringValue) import qualified Text.Blaze.Svg11.Attributes as A -import Data.List (foldl',intersperse)+import Data.List (foldl') import qualified Data.List as List svg :: [Polyline] -> Text@@ -27,15 +27,13 @@ svg11 content = docTypeSvg ! A.version "1.1" ! A.width (stringValue $ show (xmax-xmin) ++ "mm") ! A.height (stringValue $ show (ymax-ymin) ++ "mm")- ! A.viewbox (stringValue $ concat . intersperse " " . map show $ [xmin, xmax, ymin, ymax])+ ! A.viewbox (stringValue $ unwords . map show $ [0,0,xmax-xmin,ymax-ymin]) $ content -- The reason this isn't totally straightforwards is that svg has different coordinate system -- and we need to compute the requisite translation. svg' [] = mempty -- When we have a known point, we can compute said transformation: svg' polylines = thinBlueGroup $ mapM_ poly polylines- -- Otherwise, if we don't have a point to start out with, skip this polyline:- svg' ([]:rest) = svg' rest poly line = polyline ! A.points pointList where pointList = toValue $ toLazyText $ mconcat [bf (x-xmin) <> "," <> bf (ymax - y) <> " " | (x,y) <- line]
Graphics/Implicit/Export/RayTrace.hs view
@@ -1,5 +1,5 @@ -{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts #-} module Graphics.Implicit.Export.RayTrace where @@ -17,11 +17,11 @@ -- Definitions data Camera = Camera ℝ3 ℝ3 ℝ3 ℝ- deriving Show+ deriving Show data Ray = Ray ℝ3 ℝ3- deriving Show+ deriving Show data Light = Light ℝ3 ℝ- deriving Show+ deriving Show data Scene = Scene Obj3 Color [Light] Color type Color = PixelRGBA8@@ -39,178 +39,178 @@ average :: [Color] -> Color average l = - let - ((rs, gs), (bs, as)) = (\(a,b) -> (unzip a, unzip b)) $ unzip $ map - (\(PixelRGBA8 r g b a) -> ((fromIntegral r, fromIntegral g), (fromIntegral b, fromIntegral a)))- l :: (([ℝ], [ℝ]), ([ℝ],[ℝ]))- n = fromIntegral $ length l :: ℝ- (r, g, b, a) = (sum rs/n, sum gs/n, sum bs/n, sum as/n)- in PixelRGBA8- (fromIntegral . round $ r) (fromIntegral . round $ g) (fromIntegral . round $ b) (fromIntegral . round $ a)+ let + ((rs, gs), (bs, as)) = (\(a,b) -> (unzip a, unzip b)) $ unzip $ map + (\(PixelRGBA8 r g b a) -> ((fromIntegral r, fromIntegral g), (fromIntegral b, fromIntegral a)))+ l :: (([ℝ], [ℝ]), ([ℝ],[ℝ]))+ n = fromIntegral $ length l :: ℝ+ (r, g, b, a) = (sum rs/n, sum gs/n, sum bs/n, sum as/n)+ in PixelRGBA8+ (fromIntegral . round $ r) (fromIntegral . round $ g) (fromIntegral . round $ b) (fromIntegral . round $ a) -- Ray Utilities cameraRay :: Camera -> ℝ2 -> Ray cameraRay (Camera p vx vy f) (x,y) =- let- v = vx `cross3` vy- p' = p ^+^ f*^v ^+^ x*^vx ^+^ y*^vy- n = normalized (p' ^-^ p)- in- Ray p' n+ let+ v = vx `cross3` vy+ p' = p ^+^ f*^v ^+^ x*^vx ^+^ y*^vy+ n = normalized (p' ^-^ p)+ in+ Ray p' n rayFromTo :: ℝ3 -> ℝ3 -> Ray rayFromTo p1 p2 = Ray p1 (normalized $ p2 ^-^ p1) rayBounds :: Ray -> (ℝ3, ℝ3) -> ℝ2 rayBounds ray box =- let- Ray (cPx, cPy, cPz) cameraV@(cVx, cVy, cVz) = ray- ((x1,y1,z1),(x2,y2,z2)) = box- xbounds = [(x1 - cPx)/cVx, (x2-cPx)/cVx]- ybounds = [(y1-cPy)/cVy, (y2-cPy)/cVy]- zbounds = [(z1-cPz)/cVz, (z2-cPz)/cVz]- lower = maximum [minimum xbounds, minimum ybounds, minimum zbounds]- upper = minimum [maximum xbounds, maximum ybounds, maximum zbounds]- in- (lower, upper)+ let+ Ray (cPx, cPy, cPz) cameraV@(cVx, cVy, cVz) = ray+ ((x1,y1,z1),(x2,y2,z2)) = box+ xbounds = [(x1 - cPx)/cVx, (x2-cPx)/cVx]+ ybounds = [(y1-cPy)/cVy, (y2-cPy)/cVy]+ zbounds = [(z1-cPz)/cVz, (z2-cPz)/cVz]+ lower = maximum [minimum xbounds, minimum ybounds, minimum zbounds]+ upper = minimum [maximum xbounds, maximum ybounds, maximum zbounds]+ in+ (lower, upper) -- Intersection intersection :: Ray -> ((ℝ,ℝ), ℝ) -> ℝ -> Obj3 -> Maybe ℝ3 intersection r@(Ray p v) ((a, aval),b) res obj =- let- step = - if aval/(4::ℝ) > res then res- else if aval/(2::ℝ) > res then res/(2 :: ℝ)- else res/(10 :: ℝ)- a' = a + step- a'val = obj (p ^+^ a'*^v)- in if a'val < 0- then - let a'' = refine (a,a') (\s -> obj (p ^+^ s*^v))- in Just (p ^+^ a''*^v)- else if a' < b- then intersection r ((a',a'val), b) res obj- else Nothing+ let+ step = + if aval/(4::ℝ) > res then res+ else if aval/(2::ℝ) > res then res/(2 :: ℝ)+ else res/(10 :: ℝ)+ a' = a + step+ a'val = obj (p ^+^ a'*^v)+ in if a'val < 0+ then + let a'' = refine (a,a') (\s -> obj (p ^+^ s*^v))+ in Just (p ^+^ a''*^v)+ else if a' < b+ then intersection r ((a',a'val), b) res obj+ else Nothing refine :: ℝ2 -> (ℝ -> ℝ) -> ℝ refine (a, b) obj = - let- (aval, bval) = (obj a, obj b)- in if bval < aval- then refine' 10 (a, b) (aval, bval) obj- else refine' 10 (b, a) (aval, bval) obj+ let+ (aval, bval) = (obj a, obj b)+ in if bval < aval+ then refine' 10 (a, b) (aval, bval) obj+ else refine' 10 (b, a) (aval, bval) obj refine' :: Int -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ refine' 0 (a, b) _ _ = a refine' n (a, b) (aval, bval) obj = - let- mid = (a+b)/(2::ℝ)- midval = obj mid- in- if midval == 0- then mid- else if midval < 0- then refine' (pred n) (a, mid) (aval, midval) obj- else refine' (pred n) (mid, b) (midval, bval) obj+ let+ mid = (a+b)/(2::ℝ)+ midval = obj mid+ in+ if midval == 0+ then mid+ else if midval < 0+ then refine' (pred n) (a, mid) (aval, midval) obj+ else refine' (pred n) (mid, b) (midval, bval) obj intersects a b c d = case intersection a b c d of- Nothing -> False- Just _ -> True+ Nothing -> False+ Just _ -> True -- Trace traceRay :: Ray -> ℝ -> (ℝ3, ℝ3) -> Scene -> Color traceRay ray@(Ray cameraP cameraV) step box (Scene obj objColor lights defaultColor) =- let- (a,b) = rayBounds ray box- in case intersection ray ((a, obj (cameraP ^+^ a*^cameraV)), b) step obj of- Just p -> flip colorMult objColor $ (sum $ [0.2] ++ do- Light lightPos lightIntensity <- lights- let- ray'@(Ray _ v) = rayFromTo p lightPos- v' = normalized v- guard . not $ intersects ray' ((0, obj p),20) step obj- let- pval = obj p- step = 0.1 :: ℝ- dirDeriv :: ℝ3 -> ℝ- dirDeriv v = (obj (p ^+^ step*^v) ^-^ pval)/step- deriv = (dirDeriv (1,0,0), dirDeriv (0,1,0), dirDeriv (0,0,1))- normal = normalized $ deriv- unitV = normalized $ v'- proj a b = (a⋅b)*^b- dist = d p lightPos- illumination = (max 0 (normal ⋅ unitV)) * lightIntensity * (25 /dist)- rV = - let- normalComponent = proj v' normal- parComponent = v' - normalComponent- in- normalComponent - parComponent - return $ illumination*(3 + 0.3*(abs $ rV ⋅ cameraV)^2)- )- Nothing -> defaultColor+ let+ (a,b) = rayBounds ray box+ in case intersection ray ((a, obj (cameraP ^+^ a*^cameraV)), b) step obj of+ Just p -> flip colorMult objColor $ (sum $ [0.2] ++ do+ Light lightPos lightIntensity <- lights+ let+ ray'@(Ray _ v) = rayFromTo p lightPos+ v' = normalized v+ guard . not $ intersects ray' ((0, obj p),20) step obj+ let+ pval = obj p+ step = 0.1 :: ℝ+ dirDeriv :: ℝ3 -> ℝ+ dirDeriv v = (obj (p ^+^ step*^v) ^-^ pval)/step+ deriv = (dirDeriv (1,0,0), dirDeriv (0,1,0), dirDeriv (0,0,1))+ normal = normalized $ deriv+ unitV = normalized $ v'+ proj a b = (a⋅b)*^b+ dist = d p lightPos+ illumination = (max 0 (normal ⋅ unitV)) * lightIntensity * (25 /dist)+ rV = + let+ normalComponent = proj v' normal+ parComponent = v' - normalComponent+ in+ normalComponent - parComponent + return $ illumination*(3 + 0.3*(abs $ rV ⋅ cameraV)^2)+ )+ Nothing -> defaultColor instance DiscreteAproxable SymbolicObj3 DynamicImage where- discreteAprox res symbObj = dynamicImage $ generateImage pixelRenderer (round w) (round h)- where- (w,h) = (150, 150) :: ℝ2- obj = getImplicit3 symbObj- box@((x1,y1,z1), (x2,y2,z2)) = getBox3 symbObj- av :: ℝ -> ℝ -> ℝ- av a b = (a+b)/(2::ℝ)- avY = av y1 y2- avZ = av z1 z2- deviation = maximum [abs $ y1 - avY, abs $ y2 - avY, abs $ z1 - avZ, abs $ z2 - avZ]- camera = Camera (x1-deviation*(2.2::ℝ), avY, avZ) (0, -1, 0) (0,0, -1) 1.0- 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 :: Int -> Int -> Color- pixelRenderer a b = renderScreen - ((fromIntegral a :: ℝ)/w - (0.5::ℝ)) ((fromIntegral b :: ℝ)/h - (0.5 ::ℝ))- renderScreen :: ℝ -> ℝ -> Color- renderScreen a b =- let- ray = cameraRay camera (a,b)- in - average $ [- traceRay - (cameraRay camera ((a,b) ^+^ ( 0.25/w, 0.25/h)))- 2 box scene,- traceRay - (cameraRay camera ((a,b) ^+^ (-0.25/w, 0.25/h)))- 0.5 box scene,- traceRay - (cameraRay camera ((a,b) ^+^ (0.25/w, -0.25/h)))- 0.5 box scene,- traceRay - (cameraRay camera ((a,b) ^+^ (-0.25/w,-0.25/h)))- 0.5 box scene- ]+ discreteAprox res symbObj = dynamicImage $ generateImage pixelRenderer (round w) (round h)+ where+ (w,h) = (150, 150) :: ℝ2+ obj = getImplicit3 symbObj+ box@((x1,y1,z1), (x2,y2,z2)) = getBox3 symbObj+ av :: ℝ -> ℝ -> ℝ+ av a b = (a+b)/(2::ℝ)+ avY = av y1 y2+ avZ = av z1 z2+ deviation = maximum [abs $ y1 - avY, abs $ y2 - avY, abs $ z1 - avZ, abs $ z2 - avZ]+ camera = Camera (x1-deviation*(2.2::ℝ), avY, avZ) (0, -1, 0) (0,0, -1) 1.0+ 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 :: Int -> Int -> Color+ pixelRenderer a b = renderScreen + ((fromIntegral a :: ℝ)/w - (0.5::ℝ)) ((fromIntegral b :: ℝ)/h - (0.5 ::ℝ))+ renderScreen :: ℝ -> ℝ -> Color+ renderScreen a b =+ let+ ray = cameraRay camera (a,b)+ in + average $ [+ traceRay + (cameraRay camera ((a,b) ^+^ ( 0.25/w, 0.25/h)))+ 2 box scene,+ traceRay + (cameraRay camera ((a,b) ^+^ (-0.25/w, 0.25/h)))+ 0.5 box scene,+ traceRay + (cameraRay camera ((a,b) ^+^ (0.25/w, -0.25/h)))+ 0.5 box scene,+ traceRay + (cameraRay camera ((a,b) ^+^ (-0.25/w,-0.25/h)))+ 0.5 box scene+ ] instance DiscreteAproxable SymbolicObj2 DynamicImage where- discreteAprox res symbObj = dynamicImage $ generateImage pixelRenderer (round w) (round h)- where- (w,h) = (150, 150) :: ℝ2- obj = getImplicit2 symbObj- (p1@(x1,y1), p2@(x2,y2)) = getBox2 symbObj- (dx, dy) = p2 ^-^ p1- dxy = max dx dy- pixelRenderer :: Int -> Int -> Color- pixelRenderer a b = color- where- xy a b = ((x1,y2) .-^ (dxy-dx, dy-dxy)^/2) .+^ dxy*^(a/w, -b/h)- s = 0.25 :: ℝ- (a', b') = (realToFrac a, realToFrac b)- color = average [objColor $ xy a' b', objColor $ xy a' b',- objColor $ xy (a'+s) (b'+s),- objColor $ xy (a'-s) (b'-s),- objColor $ xy (a'+s) (b'+s),- objColor $ xy (a'-s) (b'-s)]- objColor p = if obj p < 0 then PixelRGBA8 150 150 160 255 else PixelRGBA8 255 255 255 0+ discreteAprox res symbObj = dynamicImage $ generateImage pixelRenderer (round w) (round h)+ where+ (w,h) = (150, 150) :: ℝ2+ obj = getImplicit2 symbObj+ (p1@(x1,y1), p2@(x2,y2)) = getBox2 symbObj+ (dx, dy) = p2 ^-^ p1+ dxy = max dx dy+ pixelRenderer :: Int -> Int -> Color+ pixelRenderer a b = color+ where+ xy a b = ((x1,y2) .-^ (dxy-dx, dy-dxy)^/2) .+^ dxy*^(a/w, -b/h)+ s = 0.25 :: ℝ+ (a', b') = (realToFrac a, realToFrac b)+ color = average [objColor $ xy a' b', objColor $ xy a' b',+ objColor $ xy (a'+s) (b'+s),+ objColor $ xy (a'-s) (b'-s),+ objColor $ xy (a'+s) (b'+s),+ objColor $ xy (a'-s) (b'-s)]+ objColor p = if obj p < 0 then PixelRGBA8 150 150 160 255 else PixelRGBA8 255 255 255 0
Graphics/Implicit/Export/Render.hs view
@@ -70,189 +70,189 @@ getMesh :: ℝ3 -> ℝ3 -> ℝ -> Obj3 -> TriangleMesh getMesh p1@(x1,y1,z1) p2@(x2,y2,z2) res obj = - let- (dx,dy,dz) = p2 ^-^ p1+ let+ (dx,dy,dz) = p2 ^-^ p1 - -- How many steps will we take on each axis?- nx = ceiling $ dx / res- ny = ceiling $ dy / res- nz = ceiling $ dz / res+ -- How many steps will we take on each axis?+ nx = ceiling $ dx / res+ ny = ceiling $ dy / res+ nz = ceiling $ dz / res - rx = dx/fromIntegral nx- ry = dy/fromIntegral ny- rz = dz/fromIntegral nz+ rx = dx/fromIntegral nx+ ry = dy/fromIntegral ny+ rz = dz/fromIntegral nz - l ! (a,b,c) = l !! c !! b !! a+ l ! (a,b,c) = l !! c !! b !! a - pZs = [ z1 + rz*n | n <- [0.. fromIntegral nz] ]- pYs = [ y1 + ry*n | n <- [0.. fromIntegral ny] ]- pXs = [ x1 + rx*n | n <- [0.. fromIntegral nx] ]+ pZs = [ z1 + rz*n | n <- [0.. fromIntegral nz] ]+ pYs = [ y1 + ry*n | n <- [0.. fromIntegral ny] ]+ pXs = [ x1 + rx*n | n <- [0.. fromIntegral nx] ] - {-# INLINE par3DList #-}- par3DList lenx leny lenz f = - [[[f - (\n -> x1 + rx*fromIntegral (mx+n)) mx - (\n -> y1 + ry*fromIntegral (my+n)) my - (\n -> z1 + rz*fromIntegral (mz+n)) mz- | mx <- [0..lenx] ] | my <- [0..leny] ] | mz <- [0..lenz] ] - `using` (parListChunk (max 1 $ div lenz 32) rdeepseq)+ {-# INLINE par3DList #-}+ par3DList lenx leny lenz f = + [[[f + (\n -> x1 + rx*fromIntegral (mx+n)) mx + (\n -> y1 + ry*fromIntegral (my+n)) my + (\n -> z1 + rz*fromIntegral (mz+n)) mz+ | mx <- [0..lenx] ] | my <- [0..leny] ] | mz <- [0..lenz] ] + `using` (parListChunk (max 1 $ div lenz 32) rdeepseq) - -- Evaluate obj to avoid waste in mids, segs, later.+ -- Evaluate obj to avoid waste in mids, segs, later. - objV = par3DList (nx+2) (ny+2) (nz+2) $ \x _ y _ z _ -> obj (x 0, y 0, z 0)+ objV = par3DList (nx+2) (ny+2) (nz+2) $ \x _ y _ z _ -> obj (x 0, y 0, z 0) - -- (1) Calculate mid poinsts on X, Y, and Z axis in 3D space.+ -- (1) Calculate mid poinsts on X, Y, and Z axis in 3D space. - midsZ = [[[- interpolate (z0, objX0Y0Z0) (z1, objX0Y0Z1) (appAB obj x0 y0) res- | x0 <- pXs | objX0Y0Z0 <- objY0Z0 | objX0Y0Z1 <- objY0Z1- ]| y0 <- pYs | objY0Z0 <- objZ0 | objY0Z1 <- objZ1- ]| z0 <- pZs | z1 <- tail pZs | objZ0 <- objV | objZ1 <- tail objV- ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq)+ midsZ = [[[+ interpolate (z0, objX0Y0Z0) (z1, objX0Y0Z1) (appAB obj x0 y0) res+ | x0 <- pXs | objX0Y0Z0 <- objY0Z0 | objX0Y0Z1 <- objY0Z1+ ]| y0 <- pYs | objY0Z0 <- objZ0 | objY0Z1 <- objZ1+ ]| z0 <- pZs | z1 <- tail pZs | objZ0 <- objV | objZ1 <- tail objV+ ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq) - midsY = [[[- interpolate (y0, objX0Y0Z0) (y1, objX0Y1Z0) (appAC obj x0 z0) res- | x0 <- pXs | objX0Y0Z0 <- objY0Z0 | objX0Y1Z0 <- objY1Z0- ]| y0 <- pYs | y1 <- tail pYs | objY0Z0 <- objZ0 | objY1Z0 <- tail objZ0- ]| z0 <- pZs | objZ0 <- objV - ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq)+ midsY = [[[+ interpolate (y0, objX0Y0Z0) (y1, objX0Y1Z0) (appAC obj x0 z0) res+ | x0 <- pXs | objX0Y0Z0 <- objY0Z0 | objX0Y1Z0 <- objY1Z0+ ]| y0 <- pYs | y1 <- tail pYs | objY0Z0 <- objZ0 | objY1Z0 <- tail objZ0+ ]| z0 <- pZs | objZ0 <- objV + ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq) - midsX = [[[- interpolate (x0, objX0Y0Z0) (x1, objX1Y0Z0) (appBC obj y0 z0) res- | x0 <- pXs | x1 <- tail pXs | objX0Y0Z0 <- objY0Z0 | objX1Y0Z0 <- tail objY0Z0- ]| y0 <- pYs | objY0Z0 <- objZ0 - ]| z0 <- pZs | objZ0 <- objV - ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq)+ midsX = [[[+ interpolate (x0, objX0Y0Z0) (x1, objX1Y0Z0) (appBC obj y0 z0) res+ | x0 <- pXs | x1 <- tail pXs | objX0Y0Z0 <- objY0Z0 | objX1Y0Z0 <- tail objY0Z0+ ]| y0 <- pYs | objY0Z0 <- objZ0 + ]| z0 <- pZs | objZ0 <- objV + ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq) - -- Calculate segments for each side+ -- Calculate segments for each side - segsZ = [[[ - map2 (inj3 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- ]|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- ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq)+ segsZ = [[[ + map2 (inj3 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+ ]|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+ ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq) - segsY = [[[ - map2 (inj2 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- ]|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- ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq)+ segsY = [[[ + map2 (inj2 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+ ]|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+ ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq) - segsX = - [[[ - map2 (inj1 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- ]|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- ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq)+ segsX = + [[[ + map2 (inj1 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+ ]|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+ ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq) - -- (3) & (4) : get and tesselate loops+ -- (3) & (4) : get and tesselate loops - sqTris = [[[- concat $ map (tesselateLoop res obj) $ getLoops $ concat [- segX''',- mapR segX''T,- mapR segY''',- segY'T',- segZ''',- mapR segZT''- ]+ sqTris = [[[+ concat $ map (tesselateLoop res obj) $ getLoops $ concat [+ segX''',+ mapR segX''T,+ mapR segY''',+ segY'T',+ segZ''',+ mapR segZT''+ ] - | segZ'''<- segZ''| segZT''<- segZT'- | segY'''<- segY''| segY'T'<- segY'T- | segX'''<- segX''| segX''T<- tail segX''+ | segZ'''<- segZ''| segZT''<- segZT'+ | segY'''<- segY''| segY'T'<- segY'T+ | segX'''<- segX''| segX''T<- tail segX'' - ]| segZ'' <- segZ' | segZT' <- segZT- | segY'' <- segY' | segY'T <- tail segY'- | segX'' <- segX'+ ]| segZ'' <- segZ' | segZT' <- segZT+ | segY'' <- segY' | segY'T <- tail segY'+ | segX'' <- segX' - ]| segZ' <- segsZ | segZT <- tail segsZ- | segY' <- segsY- | segX' <- segsX- ]- - in mergedSquareTris $ concat $ concat $ concat sqTris -- (5) merge squares, etc+ ]| segZ' <- segsZ | segZT <- tail segsZ+ | segY' <- segsY+ | segX' <- segsX+ ]+ + in mergedSquareTris $ concat $ concat $ concat sqTris -- (5) merge squares, etc getContour :: ℝ2 -> ℝ2 -> ℝ -> Obj2 -> [Polyline] getContour p1@(x1, y1) p2@(x2, y2) res obj = - let- (dx,dy) = p2 ^-^ p1+ let+ (dx,dy) = p2 ^-^ p1 - -- How many steps will we take on each axis?- nx = ceiling $ dx / res- ny = ceiling $ dy / res+ -- How many steps will we take on each axis?+ nx = ceiling $ dx / res+ ny = ceiling $ dy / res - rx = dx/fromIntegral nx- ry = dy/fromIntegral ny+ rx = dx/fromIntegral nx+ ry = dy/fromIntegral ny - l ! (a,b) = l !! b !! a+ l ! (a,b) = l !! b !! a - pYs = [ y1 + ry*n | n <- [0.. fromIntegral ny] ]- pXs = [ x1 + rx*n | n <- [0.. fromIntegral nx] ]+ pYs = [ y1 + ry*n | n <- [0.. fromIntegral ny] ]+ pXs = [ x1 + rx*n | n <- [0.. fromIntegral nx] ] - {-# INLINE par2DList #-}- par2DList lenx leny f = - [[ f- (\n -> x1 + rx*fromIntegral (mx+n)) mx - (\n -> y1 + ry*fromIntegral (my+n)) my- | mx <- [0..lenx] ] | my <- [0..leny] ]- `using` (parListChunk (max 1 $ div leny 32) rdeepseq)+ {-# INLINE par2DList #-}+ par2DList lenx leny f = + [[ f+ (\n -> x1 + rx*fromIntegral (mx+n)) mx + (\n -> y1 + ry*fromIntegral (my+n)) my+ | mx <- [0..lenx] ] | my <- [0..leny] ]+ `using` (parListChunk (max 1 $ div leny 32) rdeepseq) - -- Evaluate obj to avoid waste in mids, segs, later.+ -- Evaluate obj to avoid waste in mids, segs, later. - objV = par2DList (nx+2) (ny+2) $ \x _ y _ -> obj (x 0, y 0)+ objV = par2DList (nx+2) (ny+2) $ \x _ y _ -> obj (x 0, y 0) - -- (1) Calculate mid poinsts on X, Y, and Z axis in 3D space.+ -- (1) Calculate mid poinsts on X, Y, and Z axis in 3D space. - midsY = [[- interpolate (y0, objX0Y0) (y1, objX0Y1) (obj $* x0) res- | x0 <- pXs | objX0Y0 <- objY0 | objX0Y1 <- objY1- ]| y0 <- pYs | y1 <- tail pYs | objY0 <- objV | objY1 <- tail objV- ] `using` (parListChunk (max 1 $ div ny 32) rdeepseq)+ midsY = [[+ interpolate (y0, objX0Y0) (y1, objX0Y1) (obj $* x0) res+ | x0 <- pXs | objX0Y0 <- objY0 | objX0Y1 <- objY1+ ]| y0 <- pYs | y1 <- tail pYs | objY0 <- objV | objY1 <- tail objV+ ] `using` (parListChunk (max 1 $ div ny 32) rdeepseq) - midsX = [[- interpolate (x0, objX0Y0) (x1, objX1Y0) (obj *$ y0) res- | x0 <- pXs | x1 <- tail pXs | objX0Y0 <- objY0 | objX1Y0 <- tail objY0- ]| y0 <- pYs | objY0 <- objV - ] `using` (parListChunk (max 1 $ div ny 32) rdeepseq)+ midsX = [[+ interpolate (x0, objX0Y0) (x1, objX1Y0) (obj *$ y0) res+ | x0 <- pXs | x1 <- tail pXs | objX0Y0 <- objY0 | objX1Y0 <- tail objY0+ ]| y0 <- pYs | objY0 <- objV + ] `using` (parListChunk (max 1 $ div ny 32) rdeepseq) - -- Calculate segments for each side+ -- Calculate segments for each side - segs = [[ - getSegs (x0,y0) (x1,y1) obj- (objX0Y0, objX1Y0, objX0Y1, objX1Y1)- (midA0, midA1, midB0, midB1)- |x0<-pXs|x1<-tail pXs|midB0<-mX'' |midB1<-mX'T |midA0<-mY'' |midA1<-tail mY''- |objX0Y0<-objY0|objX1Y0<-tail objY0|objX0Y1<-objY1|objX1Y1<-tail objY1- ]|y0<-pYs|y1<-tail pYs|mX'' <-midsX|mX'T <-tail midsX|mY'' <-midsY- |objY0 <- objV | objY1 <- tail objV- ] `using` (parListChunk (max 1 $ div ny 32) rdeepseq)+ segs = [[ + getSegs (x0,y0) (x1,y1) obj+ (objX0Y0, objX1Y0, objX0Y1, objX1Y1)+ (midA0, midA1, midB0, midB1)+ |x0<-pXs|x1<-tail pXs|midB0<-mX'' |midB1<-mX'T |midA0<-mY'' |midA1<-tail mY''+ |objX0Y0<-objY0|objX1Y0<-tail objY0|objX0Y1<-objY1|objX1Y1<-tail objY1+ ]|y0<-pYs|y1<-tail pYs|mX'' <-midsX|mX'T <-tail midsX|mY'' <-midsY+ |objY0 <- objV | objY1 <- tail objV+ ] `using` (parListChunk (max 1 $ div ny 32) rdeepseq) - in cleanLoopsFromSegs $ concat $ concat $ segs -- (5) merge squares, etc+ in cleanLoopsFromSegs $ concat $ concat $ segs -- (5) merge squares, etc
Graphics/Implicit/Export/Render/Definitions.hs view
@@ -17,6 +17,6 @@ -- For use with Parallel.Strategies later instance NFData TriSquare where- rnf (Sq b z xS yS) = rnf (b,z,xS,yS)- rnf (Tris tris) = rnf tris+ rnf (Sq b z xS yS) = rnf (b,z,xS,yS)+ rnf (Tris tris) = rnf tris
Graphics/Implicit/Export/Render/GetLoops.hs view
@@ -50,23 +50,23 @@ -- In this case, we return it and empty the building loop. getLoops' segs workingLoop | head (head workingLoop) == last (last workingLoop) =- workingLoop : getLoops' segs []+ workingLoop : getLoops' segs [] -- Finally, we search for pieces that can continue the working loop, -- and stick one on if we find it. -- Otherwise... something is really screwed up. getLoops' segs workingLoop =- let- presEnd = last $ last workingLoop- connects (x:xs) = x == presEnd- possibleConts = filter connects segs- nonConts = filter (not . connects) segs- (next, unused) = if null possibleConts- then error "unclosed loop in paths given"- else (head possibleConts, tail possibleConts ++ nonConts)- in- if null next- then workingLoop : getLoops' segs []- else getLoops' unused (workingLoop ++ [next])+ let+ presEnd = last $ last workingLoop+ connects (x:xs) = x == presEnd+ possibleConts = filter connects segs+ nonConts = filter (not . connects) segs+ (next, unused) = if null possibleConts+ then error "unclosed loop in paths given"+ else (head possibleConts, tail possibleConts ++ nonConts)+ in+ if null next+ then workingLoop : getLoops' segs []+ else getLoops' unused (workingLoop ++ [next])
Graphics/Implicit/Export/Render/GetSegs.hs view
@@ -57,92 +57,92 @@ {-- # INLINE getSegs #-} getSegs p1 p2 obj (x1y1, x2y1, x1y2, x2y2) (midx1V,midx2V,midy1V,midy2V) = - let - (x,y) = p1+ let + (x,y) = p1 - -- Let's evaluate obj at a few points...- c = obj (centroid [p1,p2])+ -- Let's evaluate obj at a few points...+ c = obj (centroid [p1,p2]) - (dx,dy) = p2 ^-^ p1- res = sqrt (dx*dy)+ (dx,dy) = p2 ^-^ p1+ res = sqrt (dx*dy) - midx1 = (x, midx1V )- midx2 = (x + dx, midx2V )- midy1 = (midy1V , y )- midy2 = (midy2V, y + dy)+ midx1 = (x, midx1V )+ midx2 = (x + dx, midx2V )+ midy1 = (midy1V , y )+ midy2 = (midy2V, y + dy) - notPointLine (p1:p2:[]) = p1 /= p2+ notPointLine (p1:p2:[]) = p1 /= p2 - -- takes straight lines between mid points and subdivides them to- -- account for sharp corners, etc.+ -- takes straight lines between mid points and subdivides them to+ -- account for sharp corners, etc. - in map (refine res obj) . filter (notPointLine) $ case (x1y2 <= 0, x2y2 <= 0,- x1y1 <= 0, x2y1 <= 0) of+ in map (refine res obj) . filter (notPointLine) $ case (x1y2 <= 0, x2y2 <= 0,+ x1y1 <= 0, x2y1 <= 0) of - -- An important point here is orientation. If you imagine going along a- -- generated segment, the interior should be on the left-hand side.+ -- An important point here is orientation. If you imagine going along a+ -- generated segment, the interior should be on the left-hand side. - -- Empty Cases+ -- Empty Cases - (True, True, - True, True) -> []+ (True, True, + True, True) -> [] - (False, False,- False, False) -> []+ (False, False,+ False, False) -> [] - -- Horizontal Cases+ -- Horizontal Cases - (True, True, - False, False) -> [[midx1, midx2]]+ (True, True, + False, False) -> [[midx1, midx2]] - (False, False,- True, True) -> [[midx2, midx1]]+ (False, False,+ True, True) -> [[midx2, midx1]] - -- Vertical Cases+ -- Vertical Cases - (False, True, - False, True) -> [[midy2, midy1]]+ (False, True, + False, True) -> [[midy2, midy1]] - (True, False,- True, False) -> [[midy1, midy2]]+ (True, False,+ True, False) -> [[midy1, midy2]] - -- Corner Cases+ -- Corner Cases - (True, False,- False, False) -> [[midx1, midy2]]+ (True, False,+ False, False) -> [[midx1, midy2]] - (False, True, - True, True) -> [[midy2, midx1]]+ (False, True, + True, True) -> [[midy2, midx1]] - (True, True, - False, True) -> [[midx1, midy1]]+ (True, True, + False, True) -> [[midx1, midy1]] - (False, False,- True, False) -> [[midy1, midx1]]+ (False, False,+ True, False) -> [[midy1, midx1]] - (True, True, - True, False) -> [[midy1, midx2]]+ (True, True, + True, False) -> [[midy1, midx2]] - (False, False,- False, True) -> [[midx2, midy1]]+ (False, False,+ False, True) -> [[midx2, midy1]] - (True, False,- True, True) -> [[midx2, midy2]]+ (True, False,+ True, True) -> [[midx2, midy2]] - (False, True, - False, False) -> [[midy2, midx2]]+ (False, True, + False, False) -> [[midy2, midx2]] - -- Dual Corner Cases+ -- Dual Corner Cases - (True, False,- False, True) -> if c <= 0- then [[midx1, midy1], [midx2, midy2]]- else [[midx1, midy2], [midx2, midy1]]+ (True, False,+ False, True) -> if c <= 0+ then [[midx1, midy1], [midx2, midy2]]+ else [[midx1, midy2], [midx2, midy1]] - (False, True, - True, False) -> if c <= 0- then [[midy2, midx1], [midy1, midx2]]- else [[midy1, midx1], [midy2, midx2]]+ (False, True, + True, False) -> if c <= 0+ then [[midy2, midx1], [midy1, midx2]]+ else [[midy1, midx1], [midy2, midx2]] -- A convenience function, we don't actually care too much about@@ -150,11 +150,11 @@ {-- # INLINE getSegs' #-} getSegs' (x1, y1) (x2, y2) obj (midx1V,midx2V,midy1V,midy2V) = - let- x1y1 = obj (x1, y1)- x2y1 = obj (x2, y1)- x1y2 = obj (x1, y2)- x2y2 = obj (x2, y2)- in- getSegs (x1, y1) (x2, y2) obj (x1y1, x2y1, x1y2, x2y2) (midx1V,midx2V,midy1V,midy2V)+ let+ x1y1 = obj (x1, y1)+ x2y1 = obj (x2, y1)+ x1y2 = obj (x1, y2)+ x2y2 = obj (x2, y2)+ in+ getSegs (x1, y1) (x2, y2) obj (x1y1, x2y1, x1y2, x2y2) (midx1V,midx2V,midy1V,midy2V)
Graphics/Implicit/Export/Render/HandlePolylines.hs view
@@ -11,32 +11,32 @@ cleanLoopsFromSegs :: [Polyline] -> [Polyline] cleanLoopsFromSegs =- map reducePolyline- . joinSegs- . filter polylineNotNull+ map reducePolyline+ . joinSegs+ . filter polylineNotNull joinSegs :: [Polyline] -> [Polyline] joinSegs [] = [] joinSegs (present:remaining) =- let- findNext ((p3:ps):segs) = if p3 == last present then (Just (p3:ps), segs) else- if last ps == last present then (Just (reverse $ p3:ps), segs) else- case findNext segs of (res1,res2) -> (res1,(p3:ps):res2)- findNext [] = (Nothing, [])- in- case findNext remaining of- (Nothing, _) -> present:(joinSegs remaining)- (Just match, others) -> joinSegs $ (present ++ tail match): others+ let+ findNext ((p3:ps):segs) = if p3 == last present then (Just (p3:ps), segs) else+ if last ps == last present then (Just (reverse $ p3:ps), segs) else+ case findNext segs of (res1,res2) -> (res1,(p3:ps):res2)+ findNext [] = (Nothing, [])+ in+ case findNext remaining of+ (Nothing, _) -> present:(joinSegs remaining)+ (Just match, others) -> joinSegs $ (present ++ tail match): others reducePolyline ((x1,y1):(x2,y2):(x3,y3):others) = - if (x1,y1) == (x2,y2) then reducePolyline ((x2,y2):(x3,y3):others) else- if abs ( (y2-y1)/(x2-x1) - (y3-y1)/(x3-x1) ) < 0.0001 - || ( (x2-x1) == 0 && (x3-x1) == 0 && (y2-y1)*(y3-y1) > 0)- then reducePolyline ((x1,y1):(x3,y3):others)- else (x1,y1) : reducePolyline ((x2,y2):(x3,y3):others)+ if (x1,y1) == (x2,y2) then reducePolyline ((x2,y2):(x3,y3):others) else+ if abs ( (y2-y1)/(x2-x1) - (y3-y1)/(x3-x1) ) < 0.0001 + || ( (x2-x1) == 0 && (x3-x1) == 0 && (y2-y1)*(y3-y1) > 0)+ then reducePolyline ((x1,y1):(x3,y3):others)+ else (x1,y1) : reducePolyline ((x2,y2):(x3,y3):others) reducePolyline ((x1,y1):(x2,y2):others) = - if (x1,y1) == (x2,y2) then reducePolyline ((x2,y2):others) else (x1,y1):(x2,y2):others+ if (x1,y1) == (x2,y2) then reducePolyline ((x2,y2):others) else (x1,y1):(x2,y2):others reducePolyline l = l polylineNotNull (a:l) = not (null l)@@ -45,10 +45,10 @@ {-cleanLoopsFromSegs = - connectPolys- -- . joinSegs- . filter (not . degeneratePoly)- + connectPolys+ -- . joinSegs+ . filter (not . degeneratePoly)+ polylinesFromSegsOnGrid = undefined degeneratePoly [] = True@@ -63,14 +63,14 @@ toSegOrPoly :: Polyline -> SegOrPoly toSegOrPoly [a, b] = Seg v (a⋅vp) (a⋅v, b⋅v)- where- v@(va, vb) = normalized (b ^-^ a)- vp = (-vb, va)+ where+ v@(va, vb) = normalized (b ^-^ a)+ vp = (-vb, va) toSegOrPoly ps = Poly ps fromSegOrPoly :: SegOrPoly -> Polyline fromSegOrPoly (Seg v@(va,vb) s (a,b)) = [a*^v ^+^ t, b*^v ^+^ t]- where t = s*^(-vb, va)+ where t = s*^(-vb, va) fromSegOrPoly (Poly ps) = ps joinSegs :: [Polyline] -> [Polyline]@@ -78,31 +78,31 @@ joinSegs' :: [SegOrPoly] -> [SegOrPoly] joinSegs' segsOrPolys = polys ++ concat (map joinAligned aligned) where- polys = filter (not.isSeg) segsOrPolys- segs = filter isSeg segsOrPolys- aligned = groupWith (\(Seg basis p _) -> (basis,p)) segs+ polys = filter (not.isSeg) segsOrPolys+ segs = filter isSeg segsOrPolys+ aligned = groupWith (\(Seg basis p _) -> (basis,p)) segs joinAligned segs@((Seg b z _):_) = mergeAdjacent orderedSegs where- orderedSegs = sortBy (\(Seg _ _ (a1,_)) (Seg _ _ (b1,_)) -> compare a1 b1) segs- mergeAdjacent (pres@(Seg _ _ (x1a,x2a)) : next@(Seg _ _ (x1b,x2b)) : others) =- if x2a == x1b- then mergeAdjacent ((Seg b z (x1a,x2b)): others)- else pres : mergeAdjacent (next : others)- mergeAdjacent a = a+ orderedSegs = sortBy (\(Seg _ _ (a1,_)) (Seg _ _ (b1,_)) -> compare a1 b1) segs+ mergeAdjacent (pres@(Seg _ _ (x1a,x2a)) : next@(Seg _ _ (x1b,x2b)) : others) =+ if x2a == x1b+ then mergeAdjacent ((Seg b z (x1a,x2b)): others)+ else pres : mergeAdjacent (next : others)+ mergeAdjacent a = a joinAligned [] = [] connectPolys :: [Polyline] -> [Polyline] connectPolys [] = [] connectPolys (present:remaining) =- let- findNext (ps@(p:_):segs) = - if p == last present- then (Just ps, segs)- else (a, ps:b) where (a,b) = findNext segs- findNext [] = (Nothing, [])- in- case findNext remaining of- (Nothing, _) -> present:(connectPolys remaining)- (Just match, others) -> connectPolys $ (present ++ tail match): others+ let+ findNext (ps@(p:_):segs) = + if p == last present+ then (Just ps, segs)+ else (a, ps:b) where (a,b) = findNext segs+ findNext [] = (Nothing, [])+ in+ case findNext remaining of+ (Nothing, _) -> present:(connectPolys remaining)+ (Just match, others) -> connectPolys $ (present ++ tail match): others -}
Graphics/Implicit/Export/Render/HandleSquares.hs view
@@ -53,28 +53,28 @@ -} mergedSquareTris sqTris = - let- -- We don't need to do any work on triangles. They'll just be part of- -- the list of triangles we give back. So, the triangles coming from- -- triangles...- triTriangles = concat $ map (\(Tris a) -> a) $ filter isTris sqTris - -- We actually want to work on the quads, so we find those- squares = filter (not . isTris) sqTris- -- Collect ones that are on the same plane.- planeAligned = groupWith (\(Sq basis z _ _) -> (basis,z)) squares- -- For each plane:- -- Select for being the same range on X and then merge them on Y- -- Then vice versa.- joined = map - ( -- concat . (map joinXaligned) . groupWith (\(Sq _ _ xS _) -> xS)- concat . (map joinYaligned) . groupWith (\(Sq _ _ _ yS) -> yS)- . concat . (map joinXaligned) . groupWith (\(Sq _ _ xS _) -> xS)) - planeAligned- -- Merge them back together, and we have the desired reult!- finishedSquares = concat joined- in- -- merge them to triangles, and combine with the original triagneles.- triTriangles ++ concat (map squareToTri finishedSquares)+ let+ -- We don't need to do any work on triangles. They'll just be part of+ -- the list of triangles we give back. So, the triangles coming from+ -- triangles...+ triTriangles = concat $ map (\(Tris a) -> a) $ filter isTris sqTris + -- We actually want to work on the quads, so we find those+ squares = filter (not . isTris) sqTris+ -- Collect ones that are on the same plane.+ planeAligned = groupWith (\(Sq basis z _ _) -> (basis,z)) squares+ -- For each plane:+ -- Select for being the same range on X and then merge them on Y+ -- Then vice versa.+ joined = map + ( -- concat . (map joinXaligned) . groupWith (\(Sq _ _ xS _) -> xS)+ concat . (map joinYaligned) . groupWith (\(Sq _ _ _ yS) -> yS)+ . concat . (map joinXaligned) . groupWith (\(Sq _ _ xS _) -> xS)) + planeAligned+ -- Merge them back together, and we have the desired reult!+ finishedSquares = concat joined+ in+ -- merge them to triangles, and combine with the original triagneles.+ triTriangles ++ concat (map squareToTri finishedSquares) -- And now for a bunch of helper functions that do the heavy lifting...@@ -84,49 +84,49 @@ joinXaligned quads@((Sq b z xS _):_) =- let- orderedQuads = sortBy - (\(Sq _ _ _ (ya,_)) (Sq _ _ _ (yb,_)) -> compare ya yb)- quads- mergeAdjacent (pres@(Sq _ _ _ (y1a,y2a)) : next@(Sq _ _ _ (y1b,y2b)) : others) =- if y2a == y1b- then mergeAdjacent ((Sq b z xS (y1a,y2b)): others)- else if y1a == y2b- then mergeAdjacent ((Sq b z xS (y1b,y2a)): others)- else pres : mergeAdjacent (next : others)- mergeAdjacent a = a- in- mergeAdjacent orderedQuads+ let+ orderedQuads = sortBy + (\(Sq _ _ _ (ya,_)) (Sq _ _ _ (yb,_)) -> compare ya yb)+ quads+ mergeAdjacent (pres@(Sq _ _ _ (y1a,y2a)) : next@(Sq _ _ _ (y1b,y2b)) : others) =+ if y2a == y1b+ then mergeAdjacent ((Sq b z xS (y1a,y2b)): others)+ else if y1a == y2b+ then mergeAdjacent ((Sq b z xS (y1b,y2a)): others)+ else pres : mergeAdjacent (next : others)+ mergeAdjacent a = a+ in+ mergeAdjacent orderedQuads joinXaligned [] = [] joinYaligned quads@((Sq b z _ yS):_) =- let- orderedQuads = sortBy - (\(Sq _ _ (xa,_) _) (Sq _ _ (xb,_) _) -> compare xa xb)- quads- mergeAdjacent (pres@(Sq _ _ (x1a,x2a) _) : next@(Sq _ _ (x1b,x2b) _) : others) =- if x2a == x1b- then mergeAdjacent ((Sq b z (x1a,x2b) yS): others)- else if x1a == x2b- then mergeAdjacent ((Sq b z (x1b,x2a) yS): others)- else pres : mergeAdjacent (next : others)- mergeAdjacent a = a- in- mergeAdjacent orderedQuads+ let+ orderedQuads = sortBy + (\(Sq _ _ (xa,_) _) (Sq _ _ (xb,_) _) -> compare xa xb)+ quads+ mergeAdjacent (pres@(Sq _ _ (x1a,x2a) _) : next@(Sq _ _ (x1b,x2b) _) : others) =+ if x2a == x1b+ then mergeAdjacent ((Sq b z (x1a,x2b) yS): others)+ else if x1a == x2b+ then mergeAdjacent ((Sq b z (x1b,x2a) yS): others)+ else pres : mergeAdjacent (next : others)+ mergeAdjacent a = a+ in+ mergeAdjacent orderedQuads joinYaligned [] = [] -- Reconstruct a triangle squareToTri (Sq (b1,b2,b3) z (x1,x2) (y1,y2)) =- let- zV = b3 ^* z- (x1V, x2V) = (x1 *^ b1, x2 *^ b1)- (y1V, y2V) = (y1 *^ b2, y2 *^ b2)- a = zV ^+^ x1V ^+^ y1V- b = zV ^+^ x2V ^+^ y1V- c = zV ^+^ x1V ^+^ y2V- d = zV ^+^ x2V ^+^ y2V- in- [(a,b,c),(c,b,d)]+ let+ zV = b3 ^* z+ (x1V, x2V) = (x1 *^ b1, x2 *^ b1)+ (y1V, y2V) = (y1 *^ b2, y2 *^ b2)+ a = zV ^+^ x1V ^+^ y1V+ b = zV ^+^ x2V ^+^ y1V+ c = zV ^+^ x1V ^+^ y2V+ d = zV ^+^ x2V ^+^ y2V+ in+ [(a,b,c),(c,b,d)]
Graphics/Implicit/Export/Render/Interpolate.hs view
@@ -68,48 +68,48 @@ -- :) {-interpolate (a,aval) (b,bval) f res = - let- -- a' and b' are just a and b shifted inwards slightly.- a' = (a*95+5*b)/100- b' = (b*95+5*a)/100- -- we evaluate at them.- a'val = f a'- b'val = f b'- -- ... so we can calculate the derivatives!- deriva = abs $ 20*(aval - a'val)- derivb = abs $ 20*(bval - b'val)- -- And if one side of the function is slow...- in if abs deriva < 0.1 || abs derivb < 0.1- -- We use a binary search interpolation!- then- -- The best case is that it crosses between a and a'- if aval*a'val < 0- then- interpolate_bin 0 (a,aval) (a',a'val) f- -- Or between b' and b- else if bval*b'val < 0- then interpolate_bin 0 (b',b'val) (b,bval) f- -- But in the worst case, we get to shrink to (a',b') :)- else interpolate_bin 0 (a',a'val) (b',b'val) f- -- Otherwise, we use our friend, linear interpolation!- else- -- again...- -- The best case is that it crosses between a and a'- if aval*a'val < 0- then- interpolate_lin 0 (a,aval) (a',a'val) f- -- Or between b' and b- else if bval*b'val < 0- then interpolate_lin 0 (b',b'val) (b,bval) f- -- But in the worst case, we get to shrink to (a',b') :)- else interpolate_lin 0 (a',a'val) (b',b'val) f+ let+ -- a' and b' are just a and b shifted inwards slightly.+ a' = (a*95+5*b)/100+ b' = (b*95+5*a)/100+ -- we evaluate at them.+ a'val = f a'+ b'val = f b'+ -- ... so we can calculate the derivatives!+ deriva = abs $ 20*(aval - a'val)+ derivb = abs $ 20*(bval - b'val)+ -- And if one side of the function is slow...+ in if abs deriva < 0.1 || abs derivb < 0.1+ -- We use a binary search interpolation!+ then+ -- The best case is that it crosses between a and a'+ if aval*a'val < 0+ then+ interpolate_bin 0 (a,aval) (a',a'val) f+ -- Or between b' and b+ else if bval*b'val < 0+ then interpolate_bin 0 (b',b'val) (b,bval) f+ -- But in the worst case, we get to shrink to (a',b') :)+ else interpolate_bin 0 (a',a'val) (b',b'val) f+ -- Otherwise, we use our friend, linear interpolation!+ else+ -- again...+ -- The best case is that it crosses between a and a'+ if aval*a'val < 0+ then+ interpolate_lin 0 (a,aval) (a',a'val) f+ -- Or between b' and b+ else if bval*b'val < 0+ then interpolate_lin 0 (b',b'val) (b,bval) f+ -- But in the worst case, we get to shrink to (a',b') :)+ else interpolate_lin 0 (a',a'val) (b',b'val) f -} interpolate (a,aval) (b,bval) f res =- -- Make sure aval > bval, then pass to interpolate_bin- if aval > bval- then interpolate_lin 0 (a,aval) (b,bval) f- else interpolate_lin 0 (b,bval) (a,aval) f+ -- Make sure aval > bval, then pass to interpolate_bin+ if aval > bval+ then interpolate_lin 0 (a,aval) (b,bval) f+ else interpolate_lin 0 (b,bval) (a,aval) f -- Yay, linear interpolation! @@ -117,32 +117,32 @@ -- (n is to cut us off if recursion goes too deep) interpolate_lin n (a, aval) (b, bval) obj | aval /= bval= - let- -- Interpolate and evaluate- mid = a + (b-a)*aval/(aval-bval)- midval = obj mid- -- Are we done?- in if midval == 0- then mid- -- - else let- (a', a'val, b', b'val, improveRatio) = - if midval > 0- then (mid, midval, b, bval, midval/aval)- else (a, aval, mid, midval, midval/bval)+ let+ -- Interpolate and evaluate+ mid = a + (b-a)*aval/(aval-bval)+ midval = obj mid+ -- Are we done?+ in if midval == 0+ then mid+ -- + else let+ (a', a'val, b', b'val, improveRatio) = + if midval > 0+ then (mid, midval, b, bval, midval/aval)+ else (a, aval, mid, midval, midval/bval) - -- some times linear interpolate doesn't work,- -- because one side is very close to zero and flat- -- we catch it because the interval won't shrink when- -- this is the case. To test this, we look at whether- -- the replaced point evaluates to substantially closer- -- to zero than the previous one.- in if improveRatio < 0.3 && n < 4- -- And we continue on.- then interpolate_lin (n+1) (a', a'val) (b', b'val) obj- -- But if not, we switch to binary interpolate, which is - -- immune to this problem- else interpolate_bin (n+1) (a', a'val) (b', b'val) obj+ -- some times linear interpolate doesn't work,+ -- because one side is very close to zero and flat+ -- we catch it because the interval won't shrink when+ -- this is the case. To test this, we look at whether+ -- the replaced point evaluates to substantially closer+ -- to zero than the previous one.+ in if improveRatio < 0.3 && n < 4+ -- And we continue on.+ then interpolate_lin (n+1) (a', a'val) (b', b'val) obj+ -- But if not, we switch to binary interpolate, which is + -- immune to this problem+ else interpolate_bin (n+1) (a', a'val) (b', b'val) obj -- And a fallback: interpolate_lin _ (a, _) _ _ = a@@ -152,17 +152,17 @@ -- The termination case: interpolate_bin 5 (a,aval) (b,bval) f = - if abs aval < abs bval- then a- else b+ if abs aval < abs bval+ then a+ else b -- Otherwise, have fun with mid! interpolate_bin n (a,aval) (b,bval) f =- let- mid = (a+b)/2- midval = f mid- in if midval > 0- then interpolate_bin (n+1) (mid,midval) (b,bval) f- else interpolate_bin (n+1) (a,aval) (mid,midval) f+ let+ mid = (a+b)/2+ midval = f mid+ in if midval > 0+ then interpolate_bin (n+1) (mid,midval) (b,bval) f+ else interpolate_bin (n+1) (a,aval) (mid,midval) f
Graphics/Implicit/Export/Render/RefineSegs.hs view
@@ -21,40 +21,40 @@ detail' res obj [p1@(x1,y1), p2@(x2,y2)] | (x2-x1)^2 + (y2-y1)^2 > res^2/200 = - detail 0 res obj [p1,p2]+ detail 0 res obj [p1,p2] detail' _ _ a = a -- detail adds new points to a polyline to add more detail. detail :: Int -> ℝ -> (ℝ2 -> ℝ) -> [ℝ2] -> [ℝ2] detail n res obj [p1, p2] | n < 2 =- let- mid = centroid [p1,p2]- midval = obj mid - in if abs midval < res / 40- then [p1, p2]- else let- normal = (\(a,b) -> (b, -a)) $ normalized (p2 ^-^ p1) - derivN = -(obj (mid ^-^ (normal ^* (midval/2))) - midval) * (2/midval)- in if abs derivN > 0.5 && abs derivN < 2 && abs (midval/derivN) < 3*res- then let- mid' = mid ^-^ (normal ^* (midval / derivN))- in detail (n+1) res obj [p1, mid'] - ++ tail (detail (n+1) res obj [mid', p2] )- else let- derivX = (obj (mid ^+^ (res/100, 0)) - midval)*100/res- derivY = (obj (mid ^+^ (0, res/100)) - midval)*100/res- derivNormSq = derivX^2 + derivY^2- in if abs derivNormSq > 0.09 && abs derivNormSq < 4 && abs (midval/sqrt derivNormSq) < 3*res- then let- (dX, dY) = (- derivX*midval/derivNormSq, - derivY*midval/derivNormSq)- mid' = mid ^+^ (dX, dY)- midval' = obj mid'- posRatio = midval/(midval - midval')- mid'' = mid ^+^ (dX*posRatio, dY*posRatio)- in - detail (n+1) res obj [p1, mid''] ++ tail (detail (n+1) res obj [mid'', p2] )- else [p1, p2]+ let+ mid = centroid [p1,p2]+ midval = obj mid + in if abs midval < res / 40+ then [p1, p2]+ else let+ normal = (\(a,b) -> (b, -a)) $ normalized (p2 ^-^ p1) + derivN = -(obj (mid ^-^ (normal ^* (midval/2))) - midval) * (2/midval)+ in if abs derivN > 0.5 && abs derivN < 2 && abs (midval/derivN) < 3*res+ then let+ mid' = mid ^-^ (normal ^* (midval / derivN))+ in detail (n+1) res obj [p1, mid'] + ++ tail (detail (n+1) res obj [mid', p2] )+ else let+ derivX = (obj (mid ^+^ (res/100, 0)) - midval)*100/res+ derivY = (obj (mid ^+^ (0, res/100)) - midval)*100/res+ derivNormSq = derivX^2 + derivY^2+ in if abs derivNormSq > 0.09 && abs derivNormSq < 4 && abs (midval/sqrt derivNormSq) < 3*res+ then let+ (dX, dY) = (- derivX*midval/derivNormSq, - derivY*midval/derivNormSq)+ mid' = mid ^+^ (dX, dY)+ midval' = obj mid'+ posRatio = midval/(midval - midval')+ mid'' = mid ^+^ (dX*posRatio, dY*posRatio)+ in + detail (n+1) res obj [p1, mid''] ++ tail (detail (n+1) res obj [mid'', p2] )+ else [p1, p2] detail _ _ _ x = x@@ -63,23 +63,23 @@ simplify1 :: [ℝ2] -> [ℝ2] simplify1 (a:b:c:xs) =- if abs ( ((b ^-^ a) ⋅ (c ^-^ a)) - magnitude (b ^-^ a) * magnitude (c ^-^ a) ) < 0.0001- then simplify1 (a:c:xs)- else a : simplify1 (b:c:xs)+ if abs ( ((b ^-^ a) ⋅ (c ^-^ a)) - magnitude (b ^-^ a) * magnitude (c ^-^ a) ) < 0.0001+ then simplify1 (a:c:xs)+ else a : simplify1 (b:c:xs) simplify1 a = a {- simplify2 :: ℝ -> [ℝ2] -> [ℝ2] simplify2 res [a,b,c,d] = - if norm (b - c) < res/10- then [a, ((b + c) / (2::ℝ)), d]- else [a,b,c,d]+ if norm (b - c) < res/10+ then [a, ((b + c) / (2::ℝ)), d]+ else [a,b,c,d] simplify2 _ a = a simplify3 (a:as) | length as > 5 = simplify3 $ a : half (init as) ++ [last as]- where- half (a:b:xs) = a : half xs- half a = a+ where+ half (a:b:xs) = a : half xs+ half a = a simplify3 a = a -}
Graphics/Implicit/Export/Render/TesselateLoops.hs view
@@ -25,28 +25,28 @@ -} tesselateLoop res obj [[_,_], as@(_:_:_:_),[_,_], bs@(_:_:_:_)] | length as == length bs =- concat $ map (tesselateLoop res obj) $ - [[[a1,b1],[b1,b2],[b2,a2],[a2,a1]] | ((a1,b1),(a2,b2)) <- zip (init pairs) (tail pairs)]- where pairs = zip (reverse as) bs+ concat $ map (tesselateLoop res obj) $ + [[[a1,b1],[b1,b2],[b2,a2],[a2,a1]] | ((a1,b1),(a2,b2)) <- zip (init pairs) (tail pairs)]+ where pairs = zip (reverse as) bs tesselateLoop res obj [as@(_:_:_:_),[_,_], bs@(_:_:_:_), [_,_] ] | length as == length bs =- concat $ map (tesselateLoop res obj) $ - [[[a1,b1],[b1,b2],[b2,a2],[a2,a1]] | ((a1,b1),(a2,b2)) <- zip (init pairs) (tail pairs)]- where pairs = zip (reverse as) bs+ concat $ map (tesselateLoop res obj) $ + [[[a1,b1],[b1,b2],[b2,a2],[a2,a1]] | ((a1,b1),(a2,b2)) <- zip (init pairs) (tail pairs)]+ where pairs = zip (reverse as) bs {- #__# | | -> if parallegram then quad #__# -}-{- We're going to disable quads for now.+ tesselateLoop res obj [[a,_],[b,_],[c,_],[d,_]] | centroid [a,c] == centroid [b,d] =- let- b1 = normalized $ a ^-^ b- b2 = normalized $ c ^-^ b- b3 = b1 `cross3` b2- in [Sq (b1,b2,b3) (a ⋅ b3) (a ⋅ b1, c ⋅ b1) (a ⋅ b2, c ⋅ b2) ]--}+ let+ b1 = normalized $ a ^-^ b+ b2 = normalized $ c ^-^ b+ b3 = b1 `cross3` b2+ in [Sq (b1,b2,b3) (a ⋅ b3) (a ⋅ b1, c ⋅ b1) (a ⋅ b2, c ⋅ b2) ]+ {- #__# #__# | | -> | /|@@ -54,46 +54,46 @@ -} tesselateLoop res obj [[a,_],[b,_],[c,_],[d,_]] | obj (centroid [a,c]) < res/30 =- return $ Tris $ [(a,b,c),(a,c,d)]+ return $ Tris $ [(a,b,c),(a,c,d)] -- Fallback case: make fans tesselateLoop res obj pathSides = return $ Tris $- let- path' = concat $ map init pathSides- (early_tris,path) = shrinkLoop 0 path' res obj- in if null path- then early_tris- else let- mid@(midx,midy,midz) = centroid path- midval = obj mid- preNormal = foldl1 (^+^) $- [ a `cross3` b | (a,b) <- zip path (tail path ++ [head path]) ]- preNormalNorm = magnitude preNormal- normal = preNormal ^/ preNormalNorm- deriv = (obj (mid ^+^ (normal ^* (res/100)) ) ^-^ midval)/res*100- mid' = mid ^-^ normal ^* (midval/deriv)- in if abs midval > res/50 && preNormalNorm > 0.5 && abs deriv > 0.5 - && abs (midval/deriv) < 2*res && 3*abs (obj mid') < abs midval- then early_tris ++ [(a,b,mid') | (a,b) <- zip path (tail path ++ [head path]) ]- else early_tris ++ [(a,b,mid) | (a,b) <- zip path (tail path ++ [head path]) ]+ let+ path' = concat $ map init pathSides+ (early_tris,path) = shrinkLoop 0 path' res obj+ in if null path+ then early_tris+ else let+ mid@(midx,midy,midz) = centroid path+ midval = obj mid+ preNormal = foldl1 (^+^) $+ [ a `cross3` b | (a,b) <- zip path (tail path ++ [head path]) ]+ preNormalNorm = magnitude preNormal+ normal = preNormal ^/ preNormalNorm+ deriv = (obj (mid ^+^ (normal ^* (res/100)) ) ^-^ midval)/res*100+ mid' = mid ^-^ normal ^* (midval/deriv)+ in if abs midval > res/50 && preNormalNorm > 0.5 && abs deriv > 0.5 + && abs (midval/deriv) < 2*res && 3*abs (obj mid') < abs midval+ then early_tris ++ [(a,b,mid') | (a,b) <- zip path (tail path ++ [head path]) ]+ else early_tris ++ [(a,b,mid) | (a,b) <- zip path (tail path ++ [head path]) ] shrinkLoop :: Int -> [ℝ3] -> ℝ -> Obj3 -> ([Triangle], [ℝ3]) shrinkLoop _ path@[a,b,c] res obj =- if abs (obj $ centroid [a,b,c]) < res/50- then - ( [(a,b,c)], [])- else - ([], path)+ if abs (obj $ centroid [a,b,c]) < res/50+ then + ( [(a,b,c)], [])+ else + ([], path) shrinkLoop n path@(a:b:c:xs) res obj | n < length path =- if abs (obj (centroid [a,c])) < res/50- then - let (tris,remainder) = shrinkLoop 0 (a:c:xs) res obj- in ((a,b,c):tris, remainder)- else - shrinkLoop (n+1) (b:c:xs ++ [a]) res obj+ if abs (obj (centroid [a,c])) < res/50+ then + let (tris,remainder) = shrinkLoop 0 (a:c:xs) res obj+ in ((a,b,c):tris, remainder)+ else + shrinkLoop (n+1) (b:c:xs ++ [a]) res obj shrinkLoop _ path _ _ = ([],path)
Graphics/Implicit/Export/Symbolic/Rebound2.hs view
@@ -5,8 +5,8 @@ rebound2 :: BoxedObj2 -> BoxedObj2 rebound2 (obj, (a,b)) = - let- d :: ℝ2- d = (b ^-^ a) ^/ 10- in - (obj, ((a ^-^ d), (b ^+^ d)))+ let+ d :: ℝ2+ d = (b ^-^ a) ^/ 10+ in + (obj, ((a ^-^ d), (b ^+^ d)))
Graphics/Implicit/Export/Symbolic/Rebound3.hs view
@@ -5,9 +5,9 @@ rebound3 :: BoxedObj3 -> BoxedObj3 rebound3 (obj, (a,b)) = - let- d :: ℝ3- d = (b ^-^ a) ^/ 10- in - (obj, ((a ^-^ d), (b ^+^ d)))+ let+ d :: ℝ3+ d = (b ^-^ a) ^/ 10+ in + (obj, ((a ^-^ d), (b ^+^ d)))
Graphics/Implicit/Export/SymbolicFormats.hs view
@@ -91,7 +91,9 @@ buildS2 (Circle r) = call "circle" [bf r] [] -buildS2 (PolygonR 0 points) = call "polygon" [buildVector [x,y] | (x,y) <- points] []- where buildVector comps = "[" <> mconcat (intersperse "," $ map bf comps) <> "]"+buildS2 (PolygonR 0 points) =+ call "polygon" [buildVector [x,y] | (x,y) <- points] []+ where buildVector comps =+ "[" <> mconcat (intersperse "," $ map bf comps) <> "]"
Graphics/Implicit/Export/SymbolicObj2.hs view
@@ -25,46 +25,46 @@ import Data.VectorSpace instance DiscreteAproxable SymbolicObj2 [Polyline] where- discreteAprox res obj = symbolicGetContour res obj+ discreteAprox res obj = symbolicGetContour res obj symbolicGetOrientedContour :: ℝ -> SymbolicObj2 -> [Polyline] symbolicGetOrientedContour res symbObj = map orient $ symbolicGetContour res symbObj- where- obj = getImplicit2 symbObj- orient :: Polyline -> Polyline- orient points@(x:y:_) = - let - v = (\(a,b) -> (b, -a)) (y - x)- dv = v ^/ (magnitude v / res / 0.1)- in if obj (x + dv) - obj x > 0- then points- else reverse points+ where+ obj = getImplicit2 symbObj+ orient :: Polyline -> Polyline+ orient points@(x:y:_) = + let + v = (\(a,b) -> (b, -a)) (y - x)+ dv = v ^/ (magnitude v / res / 0.1)+ in if obj (x + dv) - obj x > 0+ then points+ else reverse points symbolicGetContour :: ℝ -> SymbolicObj2 -> [Polyline] symbolicGetContour _ (RectR 0 (x1,y1) (x2,y2)) = [[ (x1,y1), (x2,y1), (x2,y2), (x1,y2), (x1,y1) ]] symbolicGetContour res (Circle r) = [[ ( r*cos(2*pi*m/n), r*sin(2*pi*m/n) ) | m <- [0.. n] ]] where- n = max 5 (fromIntegral $ ceiling $ 2*pi*r/res)+ n = max 5 (fromIntegral $ ceiling $ 2*pi*r/res) symbolicGetContour res (Translate2 v obj) = map (map (+ v) ) $ symbolicGetContour res obj symbolicGetContour res (Scale2 s@(a,b) obj) = map (map (⋯* s)) $ symbolicGetContour (res/sc) obj- where sc = max a b+ where sc = max a b symbolicGetContour res obj = case rebound2 (getImplicit2 obj, getBox2 obj) of- (obj, (a,b)) -> Render.getContour a b res obj+ (obj, (a,b)) -> Render.getContour a b res obj symbolicGetContourMesh :: ℝ -> SymbolicObj2 -> [(ℝ2,ℝ2,ℝ2)] symbolicGetContourMesh res (Translate2 v obj) = map (\(a,b,c) -> (a + v, b + v, c + v) ) $- symbolicGetContourMesh res obj+ symbolicGetContourMesh res obj symbolicGetContourMesh res (Scale2 s@(a,b) obj) = map (\(a,b,c) -> (a ⋯* s, b ⋯* s, c ⋯* 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)) = [((x1,y1), (x2,y1), (x2,y2)), ((x2,y2), (x1,y2), (x1,y1)) ] symbolicGetContourMesh res (Circle r) = - [ ((0,0),- (r*cos(2*pi*m/n), r*sin(2*pi*m/n)), - (r*cos(2*pi*(m+1)/n), r*sin(2*pi*(m+1)/n)) - )| m <- [0.. n-1] ] - where- n = max 5 (fromIntegral $ ceiling $ 2*pi*r/res)+ [ ((0,0),+ (r*cos(2*pi*m/n), r*sin(2*pi*m/n)), + (r*cos(2*pi*(m+1)/n), r*sin(2*pi*(m+1)/n)) + )| m <- [0.. n-1] ] + where+ n = max 5 (fromIntegral $ ceiling $ 2*pi*r/res) symbolicGetContourMesh res obj = case rebound2 (getImplicit2 obj, getBox2 obj) of- (obj, (a,b)) -> getContourMesh a b (res,res) obj+ (obj, (a,b)) -> getContourMesh a b (res,res) obj
Graphics/Implicit/Export/SymbolicObj3.hs view
@@ -26,68 +26,68 @@ import Graphics.Implicit.Export.Symbolic.Rebound3 --import Graphics.Implicit.Export.Util (divideMeshTo, dividePolylineTo) import Graphics.Implicit.Export.Util (normTriangle)-import Data.VectorSpace instance DiscreteAproxable SymbolicObj3 TriangleMesh where- discreteAprox res obj = symbolicGetMesh res obj+ discreteAprox res obj = symbolicGetMesh res obj instance DiscreteAproxable SymbolicObj3 NormedTriangleMesh where- discreteAprox res obj = map (normTriangle res (getImplicit3 obj)) $ symbolicGetMesh res obj+ discreteAprox res obj = map (normTriangle res (getImplicit3 obj)) $ symbolicGetMesh res obj symbolicGetMesh :: ℝ -> SymbolicObj3 -> [(ℝ3, ℝ3, ℝ3)] +{-- -- A translated objects mesh is its mesh translated. symbolicGetMesh res (Translate3 v obj) = - map (\(a,b,c) -> (a ^+^ v, b ^+^ v, c ^+^ v) ) (symbolicGetMesh res obj)+ map (\(a,b,c) -> (a S.+ v, b S.+ v, c S.+ v) ) (symbolicGetMesh res obj) -- A scaled objects mesh is its mesh scaled symbolicGetMesh res (Scale3 s obj) =- let- mesh :: [(ℝ3, ℝ3, ℝ3)]- mesh = symbolicGetMesh res obj- scaleTriangle :: (ℝ3, ℝ3, ℝ3) -> (ℝ3, ℝ3, ℝ3)- scaleTriangle (a,b,c) = (s ⋯* a, s ⋯* b, s ⋯* c)- in map scaleTriangle mesh+ let+ mesh :: [(ℝ3, ℝ3, ℝ3)]+ mesh = symbolicGetMesh res obj+ scaleTriangle :: (ℝ3, ℝ3, ℝ3) -> (ℝ3, ℝ3, ℝ3)+ scaleTriangle (a,b,c) = (s S.⋯* a, s S.⋯* b, s S.⋯* c)+ in map scaleTriangle mesh -- A couple triangles make a cube... symbolicGetMesh _ (Rect3R 0 (x1,y1,z1) (x2,y2,z2)) = - let- square a b c d = [(a,b,c),(d,a,c)]- rsquare a b c d = [(c,b,a),(c,a,d)]- in- rsquare (x1,y1,z1) (x2,y1,z1) (x2,y2,z1) (x1,y2,z1)- ++ square (x1,y1,z2) (x2,y1,z2) (x2,y2,z2) (x1,y2,z2)- ++ square (x1,y1,z1) (x2,y1,z1) (x2,y1,z2) (x1,y1,z2)- ++ rsquare (x1,y2,z1) (x2,y2,z1) (x2,y2,z2) (x1,y2,z2)- ++ square (x1,y1,z1) (x1,y1,z2) (x1,y2,z2) (x1,y2,z1)- ++ rsquare (x2,y1,z1) (x2,y1,z2) (x2,y2,z2) (x2,y2,z1)+ let+ square a b c d = [(a,b,c),(d,a,c)]+ rsquare a b c d = [(c,b,a),(c,a,d)]+ in+ rsquare (x1,y1,z1) (x2,y1,z1) (x2,y2,z1) (x1,y2,z1)+ ++ square (x1,y1,z2) (x2,y1,z2) (x2,y2,z2) (x1,y2,z2)+ ++ square (x1,y1,z1) (x2,y1,z1) (x2,y1,z2) (x1,y1,z2)+ ++ rsquare (x1,y2,z1) (x2,y2,z1) (x2,y2,z2) (x1,y2,z2)+ ++ square (x1,y1,z1) (x1,y1,z2) (x1,y2,z2) (x1,y2,z1)+ ++ rsquare (x2,y1,z1) (x2,y1,z2) (x2,y2,z2) (x2,y2,z1) -- Use spherical coordinates to create an easy tesselation of a sphere symbolicGetMesh res (Sphere r) = half1 ++ half2- where- -- Convenience functions for mesh generation- square a b c d = [(a,b,c),(d,a,c)]- rsquare a b c d = [(c,b,a),(c,a,d)]- -- Number of steps of φ and θ respectivly- m = max 3 (fromIntegral $ ceiling $ 1.5*r/res)- n = 2*m- -- Spherical coordinates- spherical θ φ = (r*cos(θ), r*sin(θ)*cos(φ), r*sin(θ)*sin(φ))- -- Function placing steps on sphere- f n' m' = spherical (2*pi*n'/n) (pi*m'/m)- -- Mesh in two pieces..- half1 = concat [ square (f m1 m2) (f (m1+1) m2) (f (m1+1) (m2+1)) (f m1 (m2+1)) - | m1 <- [0.. m-1], m2 <- [0.. m-1] ]- half2 = concat [ rsquare (f m1 m2) (f (m1+1) m2) (f (m1+1) (m2+1)) (f m1 (m2+1)) - | m1 <- [m.. n-1], m2 <- [0.. m-1] ]+ where+ -- Convenience functions for mesh generation+ square a b c d = [(a,b,c),(d,a,c)]+ rsquare a b c d = [(c,b,a),(c,a,d)]+ -- Number of steps of φ and θ respectivly+ m = max 3 (fromIntegral $ ceiling $ 1.5*r/res)+ n = 2*m+ -- Spherical coordinates+ spherical θ φ = (r*cos(θ), r*sin(θ)*cos(φ), r*sin(θ)*sin(φ))+ -- Function placing steps on sphere+ f n' m' = spherical (2*pi*n'/n) (pi*m'/m)+ -- Mesh in two pieces..+ half1 = concat [ square (f m1 m2) (f (m1+1) m2) (f (m1+1) (m2+1)) (f m1 (m2+1)) + | m1 <- [0.. m-1], m2 <- [0.. m-1] ]+ half2 = concat [ rsquare (f m1 m2) (f (m1+1) m2) (f (m1+1) (m2+1)) (f m1 (m2+1)) + | m1 <- [m.. n-1], m2 <- [0.. m-1] ] {-symbolicGetMesh res (UnionR3 r [ExtrudeR ra obja ha, ExtrudeR rb objb hb]) - | ha == hb && ra == rb = symbolicGetMesh res $ ExtrudeR ra (UnionR2 r [obja, objb]) ha+ | ha == hb && ra == rb = symbolicGetMesh res $ ExtrudeR ra (UnionR2 r [obja, objb]) ha symbolicGetMesh res (UnionR3 r [ExtrudeR ra obja ha, ExtrudeR rb objb hb, ExtrudeR rc objc hc]) - | ha == hb && ha == hc && ra == rb && ra == rc = - symbolicGetMesh res $ ExtrudeR ra (UnionR2 r [obja, objb, objc]) ha-}+ | ha == hb && ha == hc && ra == rb && ra == rc = + symbolicGetMesh res $ ExtrudeR ra (UnionR2 r [obja, objb, objc]) ha-} -- We can compute a mesh of a rounded, extruded object from it contour, -- contour filling trinagles, and magic.@@ -96,143 +96,144 @@ -- - generate the the top by taking the contour fill and -- calculating an appropriate z height. symbolicGetMesh res (ExtrudeR r obj2 h) = - let- -- Get a Obj2 (magnitude descriptor object)- obj2mag :: ℝ2 -> ℝ -- Obj2- obj2mag = getImplicit2 obj2- -- The amount that a point (x,y) on the top should be lifted- -- from h-r. Because of rounding, the edges should be h-r,- -- but it should increase inwards.- dh x y = sqrt (r^2 - ( max 0 $ min r $ r+obj2mag (x,y))^2)- -- Turn a polyline into a list of its segments- segify (a:b:xs) = (a,b):(segify $ b:xs)- segify _ = []- -- Flip a triangle. It's the same triangle with opposite handedness.- flipTri (a,b,c) = (a,c,b)- -- Turn a segment a--b into a list of triangles forming (a--b)×(r,h-r)- -- The dh stuff is to compensate for rounding errors, etc, and ensure that- -- the sides meet the top and bottom- segToSide (x1,y1) (x2,y2) =- [((x1,y1,r-dh x1 y1), (x2,y2,r-dh x2 y2), (x2,y2,h-r+dh x2 y2)), - ((x1,y1,r-dh x1 y1), (x2,y2,h-r+dh x2 y2), (x1,y1,h-r+dh x1 y1)) ]- -- Get a contour polyline for obj2, turn it into a list of segments- segs = concat $ map segify $ symbolicGetOrientedContour res obj2- -- Create sides for the main body of our object = segs × (r,h-r)- side_tris = concat $ map (\(a,b) -> segToSide a b) segs- -- Triangles that fill the contour. Make sure the mesh is at least (res/5) fine.- -- --res/5 because xyres won't always match up with normal res and we need to compensate.- fill_tris = {-divideMeshTo (res/5) $-} symbolicGetContourMesh res obj2- -- The bottom. Use dh to determine the z coordinates- bottom_tris = map flipTri $ [((a1,a2,r-dh a1 a2), (b1,b2,r - dh b1 b2), (c1,c2,r - dh c1 c2)) - | ((a1,a2),(b1,b2),(c1,c2)) <- fill_tris]- -- Same idea at the top.- top_tris = [((a1,a2,h-r+dh a1 a2), (b1,b2,h-r+dh b1 b2), (c1,c2,h-r+dh c1 c2)) - | ((a1,a2),(b1,b2),(c1,c2)) <- fill_tris]- in- -- Merge them all together! :)- side_tris ++ bottom_tris ++ top_tris + let+ -- Get a Obj2 (magnitude descriptor object)+ obj2mag :: ℝ2 -> ℝ -- Obj2+ obj2mag = getImplicit2 obj2+ -- The amount that a point (x,y) on the top should be lifted+ -- from h-r. Because of rounding, the edges should be h-r,+ -- but it should increase inwards.+ dh x y = sqrt (r^2 - ( max 0 $ min r $ r+obj2mag (x,y))^2)+ -- Turn a polyline into a list of its segments+ segify (a:b:xs) = (a,b):(segify $ b:xs)+ segify _ = []+ -- Flip a triangle. It's the same triangle with opposite handedness.+ flipTri (a,b,c) = (a,c,b)+ -- Turn a segment a--b into a list of triangles forming (a--b)×(r,h-r)+ -- The dh stuff is to compensate for rounding errors, etc, and ensure that+ -- the sides meet the top and bottom+ segToSide (x1,y1) (x2,y2) =+ [((x1,y1,r-dh x1 y1), (x2,y2,r-dh x2 y2), (x2,y2,h-r+dh x2 y2)), + ((x1,y1,r-dh x1 y1), (x2,y2,h-r+dh x2 y2), (x1,y1,h-r+dh x1 y1)) ]+ -- Get a contour polyline for obj2, turn it into a list of segments+ segs = concat $ map segify $ symbolicGetOrientedContour res obj2+ -- Create sides for the main body of our object = segs × (r,h-r)+ side_tris = concat $ map (\(a,b) -> segToSide a b) segs+ -- Triangles that fill the contour. Make sure the mesh is at least (res/5) fine.+ -- --res/5 because xyres won't always match up with normal res and we need to compensate.+ fill_tris = {-divideMeshTo (res/5) $-} symbolicGetContourMesh res obj2+ -- The bottom. Use dh to determine the z coordinates+ bottom_tris = map flipTri $ [((a1,a2,r-dh a1 a2), (b1,b2,r - dh b1 b2), (c1,c2,r - dh c1 c2)) + | ((a1,a2),(b1,b2),(c1,c2)) <- fill_tris]+ -- Same idea at the top.+ top_tris = [((a1,a2,h-r+dh a1 a2), (b1,b2,h-r+dh b1 b2), (c1,c2,h-r+dh c1 c2)) + | ((a1,a2),(b1,b2),(c1,c2)) <- fill_tris]+ in+ -- Merge them all together! :)+ side_tris ++ bottom_tris ++ top_tris -symbolicGetMesh res (ExtrudeRM r@0 twist scale translate obj2 h@(Left _)) = - let- -- Get a Obj2 (magnitude descriptor object)- obj2mag :: Obj2 -- = ℝ2 -> ℝ- obj2mag = getImplicit2 obj2- -- cleanup twist, scale, etc- twist' = Maybe.fromMaybe (const 0) twist- scale' = Maybe.fromMaybe (const 1) scale- translate' = Maybe.fromMaybe (const (0,0)) translate- h' = case h of- Left n -> const n- Right f -> f- -- The amount that a point (x,y) on the top should be lifted- -- from h-r. Because of rounding, the edges should be h-r,- -- but it should increase inwards.- dh x y = sqrt (r^2 - ( max 0 $ min r $ r+obj2mag (x,y))^2)- -- Turn a polyline into a list of its segments- segify (a:b:xs) = (a,b):(segify $ b:xs)- segify _ = []- -- Flip a triangle. It's the same triangle with opposite handedness.- flipTri (a,b,c) = (a,c,b)- -- The number of steps we're going to do the sides in:- n = max 4 $ fromIntegral $ ceiling $ h' (0,0)/res- -- Turn a segment a--b into a list of triangles forming - -- (a--b)×(r+(h-2r)*m/n,r+(h-2r)*(m+1)/n)- -- The dh stuff is to compensate for rounding errors, etc, and ensure that- -- the sides meet the top and bottom- -- m is the number of n steps we are up from the base of the main section- segToSide m (x1,y1) (x2,y2) =- let- -- Change across the main body of the object,- -- at (x1,y1) and (x2,y2) respectivly- mainH1 = h' (x1, y1) - 2*r + 2*dh x1 y1- mainH2 = h' (x2, y2) - 2*r + 2*dh x2 y2- -- level a (lower) and level b (upper)- la1 = r-dh x1 y1 + mainH1*m/n- lb1 = r-dh x1 y1 + mainH1*(m+1)/n- la2 = r-dh x2 y2 + mainH2*m/n- lb2 = r-dh x2 y2 + mainH2*(m+1)/n- in- -- Resulting triangles: - [((x1,y1,la1), (x2,y2,la2), (x2,y2,lb2)), - ((x1,y1,la1), (x2,y2,lb2), (x1,y1,lb1)) ]- -- Get a contour polyline for obj2, turn it into a list of segments- segs = concat $ map segify $ symbolicGetOrientedContour res obj2- -- Create sides for the main body of our object = segs × (r,h-r)- -- Many layers...- side_tris = map flipTri $ concat $- [concat $ map (\(a,b) -> segToSide m a b) segs | m <- [0.. n-1] ]- -- Triangles that fill the contour. Make sure the mesh is at least (res/5) fine.- -- --res/5 because xyres won't always match up with normal res and we need to compensate.- fill_tris = {-divideMeshTo (res/5) $-} symbolicGetContourMesh res obj2- -- The bottom. Use dh to determine the z coordinates- bottom_tris = [((a1,a2,r-dh a1 a2), (b1,b2,r - dh b1 b2), (c1,c2,r - dh c1 c2)) - | ((a1,a2),(b1,b2),(c1,c2)) <- fill_tris]- -- Same idea at the top.- top_tris = map flipTri $ [((a1,a2,h' (a1,a2) -r+dh a1 a2), (b1,b2,h' (b1,b2) -r+dh b1 b2), (c1,c2,h' (c1,c2)-r+dh c1 c2)) - | ((a1,a2),(b1,b2),(c1,c2)) <- fill_tris]- -- Mesh modifiers in individual components- k = 2*pi/360- fx :: ℝ3 -> ℝ- fx (x,y,z) = let (tx,ty) = translate' z in- scale' z *((x+tx)*cos(k*twist' z) + (y+ty)*sin(k*twist' z))- fy :: ℝ3 -> ℝ- fy (x,y,z) =let (tx,ty) = translate' z in- scale' z *((x+tx)*sin(k*twist' z) - (y+ty)*cos(k*twist' z))- -- function to transform a triangle- transformTriangle :: (ℝ3,ℝ3,ℝ3) -> (ℝ3,ℝ3,ℝ3)- transformTriangle (a@(_,_,z1), b@(_,_,z2), c@(_,_,z3)) = - ((fx a, fy a, z1), (fx b, fy b, z2), (fx c, fy c, z3))+symbolicGetMesh res (ExtrudeRM r twist scale translate obj2 h) = + let+ -- Get a Obj2 (magnitude descriptor object)+ obj2mag :: Obj2 -- = ℝ2 -> ℝ+ obj2mag = getImplicit2 obj2+ -- cleanup twist, scale, etc+ twist' = Maybe.fromMaybe (const 0) twist+ scale' = Maybe.fromMaybe (const 1) scale+ translate' = Maybe.fromMaybe (const (0,0)) translate+ h' = case h of+ Left n -> const n+ Right f -> f+ -- The amount that a point (x,y) on the top should be lifted+ -- from h-r. Because of rounding, the edges should be h-r,+ -- but it should increase inwards.+ dh x y = sqrt (r^2 - ( max 0 $ min r $ r+obj2mag (x,y))^2)+ -- Turn a polyline into a list of its segments+ segify (a:b:xs) = (a,b):(segify $ b:xs)+ segify _ = []+ -- Flip a triangle. It's the same triangle with opposite handedness.+ flipTri (a,b,c) = (a,c,b)+ -- The number of steps we're going to do the sides in:+ n = max 4 $ fromIntegral $ ceiling $ h' (0,0)/res+ -- Turn a segment a--b into a list of triangles forming + -- (a--b)×(r+(h-2r)*m/n,r+(h-2r)*(m+1)/n)+ -- The dh stuff is to compensate for rounding errors, etc, and ensure that+ -- the sides meet the top and bottom+ -- m is the number of n steps we are up from the base of the main section+ segToSide m (x1,y1) (x2,y2) =+ let+ -- Change across the main body of the object,+ -- at (x1,y1) and (x2,y2) respectivly+ mainH1 = h' (x1, y1) - 2*r + 2*dh x1 y1+ mainH2 = h' (x2, y2) - 2*r + 2*dh x2 y2+ -- level a (lower) and level b (upper)+ la1 = r-dh x1 y1 + mainH1*m/n+ lb1 = r-dh x1 y1 + mainH1*(m+1)/n+ la2 = r-dh x2 y2 + mainH2*m/n+ lb2 = r-dh x2 y2 + mainH2*(m+1)/n+ in+ -- Resulting triangles: + [((x1,y1,la1), (x2,y2,la2), (x2,y2,lb2)), + ((x1,y1,la1), (x2,y2,lb2), (x1,y1,lb1)) ]+ -- Get a contour polyline for obj2, turn it into a list of segments+ segs = concat $ map segify $ symbolicGetOrientedContour res obj2+ -- Create sides for the main body of our object = segs × (r,h-r)+ -- Many layers...+ side_tris = map flipTri $ concat $+ [concat $ map (\(a,b) -> segToSide m a b) segs | m <- [0.. n-1] ]+ -- Triangles that fill the contour. Make sure the mesh is at least (res/5) fine.+ -- --res/5 because xyres won't always match up with normal res and we need to compensate.+ fill_tris = {-divideMeshTo (res/5) $-} symbolicGetContourMesh res obj2+ -- The bottom. Use dh to determine the z coordinates+ bottom_tris = [((a1,a2,r-dh a1 a2), (b1,b2,r - dh b1 b2), (c1,c2,r - dh c1 c2)) + | ((a1,a2),(b1,b2),(c1,c2)) <- fill_tris]+ -- Same idea at the top.+ top_tris = map flipTri $ [((a1,a2,h' (a1,a2) -r+dh a1 a2), (b1,b2,h' (b1,b2) -r+dh b1 b2), (c1,c2,h' (c1,c2)-r+dh c1 c2)) + | ((a1,a2),(b1,b2),(c1,c2)) <- fill_tris]+ -- Mesh modifiers in individual components+ k = 2*pi/360+ fx :: ℝ3 -> ℝ+ fx (x,y,z) = let (tx,ty) = translate' z in+ scale' z *((x+tx)*cos(k*twist' z) + (y+ty)*sin(k*twist' z))+ fy :: ℝ3 -> ℝ+ fy (x,y,z) =let (tx,ty) = translate' z in+ scale' z *((x+tx)*sin(k*twist' z) - (y+ty)*cos(k*twist' z))+ -- function to transform a triangle+ transformTriangle :: (ℝ3,ℝ3,ℝ3) -> (ℝ3,ℝ3,ℝ3)+ transformTriangle (a@(_,_,z1), b@(_,_,z2), c@(_,_,z3)) = + ((fx a, fy a, z1), (fx b, fy b, z2), (fx c, fy c, z3)) - in- map transformTriangle (side_tris ++ bottom_tris ++ top_tris)+ in+ map transformTriangle (side_tris ++ bottom_tris ++ top_tris)+-} symbolicGetMesh res inputObj@(UnionR3 r objs) = - let- boxes = map getBox3 objs- boxedObjs = zip boxes objs- - sepFree ((box,obj):others) = - if length (filter (box3sWithin r box) boxes) > 1- then (\(a,b) -> (obj:a,b)) $ sepFree others- else (\(a,b) -> (a,obj:b)) $ sepFree others- sepFree [] = ([],[])+ let+ boxes = map getBox3 objs+ boxedObjs = zip boxes objs+ + sepFree ((box,obj):others) = + if length (filter (box3sWithin r box) boxes) > 1+ then (\(a,b) -> (obj:a,b)) $ sepFree others+ else (\(a,b) -> (a,obj:b)) $ sepFree others+ sepFree [] = ([],[]) - (dependants, independents) = sepFree boxedObjs- in if null independents- then case rebound3 (getImplicit3 inputObj, getBox3 inputObj) of- (obj, (a,b)) -> getMesh a b res obj - else if null dependants- then concat $ map (symbolicGetMesh res) independents- else concat $ - map (symbolicGetMesh res) independents - ++ [symbolicGetMesh res (UnionR3 r dependants)]+ (dependants, independents) = sepFree boxedObjs+ in if null independents+ then case rebound3 (getImplicit3 inputObj, getBox3 inputObj) of+ (obj, (a,b)) -> getMesh a b res obj + else if null dependants+ then concat $ map (symbolicGetMesh res) independents+ else concat $ + map (symbolicGetMesh res) independents + ++ [symbolicGetMesh res (UnionR3 r dependants)] -- If all that fails, coerce and apply marching cubes :( -- (rebound is for being safe about the bounding box -- -- it slightly streches it to make sure nothing will -- have problems because it is right at the edge ) symbolicGetMesh res obj = - case rebound3 (getImplicit3 obj, getBox3 obj) of- (obj, (a,b)) -> getMesh a b res obj + case rebound3 (getImplicit3 obj, getBox3 obj) of+ (obj, (a,b)) -> getMesh a b res obj
Graphics/Implicit/Export/TextBuilderUtils.hs view
@@ -28,7 +28,7 @@ import qualified Data.Monoid as Monoid import Data.Text.Lazy-import Data.Text.Lazy.Internal (defaultChunkSize)+import Data.Text.Internal.Lazy (defaultChunkSize) import Data.Text.Lazy.Builder hiding (toLazyText) import Data.Text.Lazy.Builder.RealFloat import Data.Text.Lazy.Builder.Int
Graphics/Implicit/Export/Util.hs view
@@ -12,28 +12,28 @@ normTriangle :: ℝ -> Obj3 -> Triangle -> NormedTriangle normTriangle res obj tri@(a,b,c) = - (normify a', normify b', normify c') - where - normify = normVertex res obj- a' = (a ^+^ r*^b ^+^ r*^c) ^/ 1.02- b' = (b ^+^ r*^a ^+^ r*^c) ^/ 1.02- c' = (c ^+^ r*^b ^+^ r*^a) ^/ 1.02- r = 0.01 :: ℝ+ (normify a', normify b', normify c') + where + normify = normVertex res obj+ a' = (a ^+^ r*^b ^+^ r*^c) ^/ 1.02+ b' = (b ^+^ r*^a ^+^ r*^c) ^/ 1.02+ c' = (c ^+^ r*^b ^+^ r*^a) ^/ 1.02+ r = 0.01 :: ℝ normVertex :: ℝ -> Obj3 -> ℝ3 -> (ℝ3, ℝ3) normVertex res obj p = - let- -- D_vf(p) = ( f(p) - f(p+v) ) /|v|- -- but we'll actually scale v by res, so then |v| = res- -- and that f is obj- -- and is fixed at p- -- so actually: d v = ...- d :: ℝ3 -> ℝ- d v = ( obj (p ^+^ (res/100)*^v) - obj (p ^-^ (res/100)*^v) ) / (res/50)- dx = d (1, 0, 0)- dy = d (0, 1, 0)- dz = d (0, 0, 1)- in (p, normalized (dx,dy,dz))+ let+ -- D_vf(p) = ( f(p) - f(p+v) ) /|v|+ -- but we'll actually scale v by res, so then |v| = res+ -- and that f is obj+ -- and is fixed at p+ -- so actually: d v = ...+ d :: ℝ3 -> ℝ+ d v = ( obj (p ^+^ (res/100)*^v) - obj (p ^-^ (res/100)*^v) ) / (res/50)+ dx = d (1, 0, 0)+ dy = d (0, 1, 0)+ dz = d (0, 0, 1)+ in (p, normalized (dx,dy,dz)) centroid :: (VectorSpace v, Fractional (Scalar v)) => [v] -> v centroid pts =@@ -44,63 +44,63 @@ {--- If we need to make a 2D mesh finer... divideMesh2To :: ℝ -> [(ℝ2, ℝ2, ℝ2)] -> [(ℝ2, ℝ2, ℝ2)] divideMesh2To res mesh =- let - av :: ℝ2 -> ℝ2 -> ℝ2- av a b = (a S.+ b) S./ (2.0 :: ℝ)- divideTriangle :: (ℝ2, ℝ2, ℝ2) -> [(ℝ2, ℝ2, ℝ2)]- divideTriangle (a,b,c) =- case (S.norm (a S.- b) > res, S.norm (b S.- c) > res, S.norm (c S.- a) > res) of- (False, False, False) -> [(a,b,c)]- (True, False, False) -> [(a, av a b, c), - (av a b, b, c) ]- (True, True, False) -> [(a, av a b, av a c), - (av a b, b, av a c), - (b, c, av a c)]- (True, True, True ) -> [(a, av a b, av a c), - (b, av b c, av b a), - (c, av c a, av c b),- (av b c, av a c, av a b)]- (_,_,_) -> divideTriangle (c, a, b)- in- concat $ map divideTriangle mesh+ let + av :: ℝ2 -> ℝ2 -> ℝ2+ av a b = (a S.+ b) S./ (2.0 :: ℝ)+ divideTriangle :: (ℝ2, ℝ2, ℝ2) -> [(ℝ2, ℝ2, ℝ2)]+ divideTriangle (a,b,c) =+ case (S.norm (a S.- b) > res, S.norm (b S.- c) > res, S.norm (c S.- a) > res) of+ (False, False, False) -> [(a,b,c)]+ (True, False, False) -> [(a, av a b, c), + (av a b, b, c) ]+ (True, True, False) -> [(a, av a b, av a c), + (av a b, b, av a c), + (b, c, av a c)]+ (True, True, True ) -> [(a, av a b, av a c), + (b, av b c, av b a), + (c, av c a, av c b),+ (av b c, av a c, av a b)]+ (_,_,_) -> divideTriangle (c, a, b)+ in+ concat $ map divideTriangle mesh divideMeshTo :: ℝ -> [(ℝ3, ℝ3, ℝ3)] -> [(ℝ3, ℝ3, ℝ3)] divideMeshTo res mesh =- let - av :: ℝ3 -> ℝ3 -> ℝ3- av a b = (a S.+ b) S./ (2.0 :: ℝ)- divideTriangle :: (ℝ3, ℝ3, ℝ3) -> [(ℝ3, ℝ3, ℝ3)]- divideTriangle (a,b,c) =- case (S.norm (a S.- b) > res, S.norm (b S.- c) > res, S.norm (c S.- a) > res) of- (False, False, False) -> [(a,b,c)]- (True, False, False) -> [(a, av a b, c), - (av a b, b, c) ]- (True, True, False) -> [(a, av a b, av a c), - (av a b, b, av a c), - (b, c, av a c)]- (True, True, True ) -> [(a, av a b, av a c), - (b, av b c, av b a), - (c, av c a, av c b),- (av b c, av a c, av a b)]- (_,_,_) -> divideTriangle (c, a, b)- in- concat $ map divideTriangle mesh+ let + av :: ℝ3 -> ℝ3 -> ℝ3+ av a b = (a S.+ b) S./ (2.0 :: ℝ)+ divideTriangle :: (ℝ3, ℝ3, ℝ3) -> [(ℝ3, ℝ3, ℝ3)]+ divideTriangle (a,b,c) =+ case (S.norm (a S.- b) > res, S.norm (b S.- c) > res, S.norm (c S.- a) > res) of+ (False, False, False) -> [(a,b,c)]+ (True, False, False) -> [(a, av a b, c), + (av a b, b, c) ]+ (True, True, False) -> [(a, av a b, av a c), + (av a b, b, av a c), + (b, c, av a c)]+ (True, True, True ) -> [(a, av a b, av a c), + (b, av b c, av b a), + (c, av c a, av c b),+ (av b c, av a c, av a b)]+ (_,_,_) -> divideTriangle (c, a, b)+ in+ concat $ map divideTriangle mesh dividePolylineTo :: ℝ -> [ℝ2] -> [ℝ2] dividePolylineTo res polyline =- let- av :: ℝ2 -> ℝ2 -> ℝ2- av a b = (a S.+ b) S./ (2.0 :: ℝ)- divide a b = - if S.norm (a S.- b) <= res- then [a]- else concat [divide a (av a b), divide (av a b) b]- n = length polyline- in do- m <- [0.. n]- if m /= n- then divide (polyline !! m) (polyline !! (m+1))- else [polyline !! n]+ let+ av :: ℝ2 -> ℝ2 -> ℝ2+ av a b = (a S.+ b) S./ (2.0 :: ℝ)+ divide a b = + if S.norm (a S.- b) <= res+ then [a]+ else concat [divide a (av a b), divide (av a b) b]+ n = length polyline+ in do+ m <- [0.. n]+ if m /= n+ then divide (polyline !! m) (polyline !! (m+1))+ else [polyline !! n] -}
Graphics/Implicit/ExtOpenScad.hs view
@@ -23,19 +23,19 @@ -- Small wrapper to handle parse errors, etc runOpenscad s =- let- initial = defaultObjects- rearrange (_, (varlookup, ovals, _ , _ , _)) = (varlookup, obj2s, obj3s) where- (obj2s, obj3s, others) = divideObjs ovals- in case parseProgram "" s of- Left e -> Left e- Right sts -> Right- $ fmap rearrange- $ (\sts -> do- path <- Dir.getCurrentDirectory- State.runStateT sts (initial, [], path, (), () )- )- $ Monad.mapM_ runStatementI sts+ let+ initial = defaultObjects+ rearrange (_, (varlookup, ovals, _ , _ , _)) = (varlookup, obj2s, obj3s) where+ (obj2s, obj3s, others) = divideObjs ovals+ in case parseProgram "" s of+ Left e -> Left e+ Right sts -> Right+ $ fmap rearrange+ $ (\sts -> do+ path <- Dir.getCurrentDirectory+ State.runStateT sts (initial, [], path, (), () )+ )+ $ Monad.mapM_ runStatementI sts
Graphics/Implicit/ExtOpenScad/Default.hs view
@@ -13,211 +13,211 @@ defaultObjects :: VarLookup -- = Map String OVal defaultObjects = fromList $ - defaultConstants- ++ defaultFunctions- ++ defaultFunctions2- ++ defaultFunctionsSpecial- ++ defaultModules- ++ defaultPolymorphicFunctions+ defaultConstants+ ++ defaultFunctions+ ++ defaultFunctions2+ ++ defaultFunctionsSpecial+ ++ defaultModules+ ++ defaultPolymorphicFunctions -- Missing standard ones: -- rand, lookup, defaultConstants = map (\(a,b) -> (a, toOObj (b::ℝ) ))- [("pi", pi)]+ [("pi", pi)] defaultFunctions = map (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ)))- [- ("sin", sin),- ("cos", cos),- ("tan", tan),- ("asin", asin),- ("acos", acos),- ("atan", atan),- ("sinh", sinh),- ("cosh", cosh),- ("tanh", tanh),- ("abs", abs),- ("sign", signum),- ("floor", fromIntegral . floor ),- ("ceil", fromIntegral . ceiling ),- ("round", fromIntegral . round ),- ("exp", exp),- ("ln", log),- ("log", log),- ("sign", signum),- ("sqrt", sqrt)- ]+ [+ ("sin", sin),+ ("cos", cos),+ ("tan", tan),+ ("asin", asin),+ ("acos", acos),+ ("atan", atan),+ ("sinh", sinh),+ ("cosh", cosh),+ ("tanh", tanh),+ ("abs", abs),+ ("sign", signum),+ ("floor", fromIntegral . floor ),+ ("ceil", fromIntegral . ceiling ),+ ("round", fromIntegral . round ),+ ("exp", exp),+ ("ln", log),+ ("log", log),+ ("sign", signum),+ ("sqrt", sqrt)+ ] defaultFunctions2 = map (\(a,b) -> (a, toOObj (b :: ℝ -> ℝ -> ℝ) ))- [- ("max", max),- ("min", min),- ("atan2", atan2),- ("pow", (**))- ]+ [+ ("max", max),+ ("min", min),+ ("atan2", atan2),+ ("pow", (**))+ ] defaultFunctionsSpecial = - [- ("map", toOObj $ flip $ - (map :: (OVal -> OVal) -> [OVal] -> [OVal] ) - )- - ]+ [+ ("map", toOObj $ flip $ + (map :: (OVal -> OVal) -> [OVal] -> [OVal] ) + )+ + ] defaultModules =- map (\(a,b) -> (a, OModule b)) primitives+ map (\(a,b) -> (a, OModule b)) primitives -- more complicated ones: defaultPolymorphicFunctions = - [ - ("+", sum),- ("sum", sum),- ("*", prod),- ("prod", prod),- ("/", div),- ("-", toOObj sub), - ("^", toOObj ((**) :: ℝ -> ℝ -> ℝ)), - ("negate", toOObj negate),- ("index", toOObj index),- ("splice", toOObj osplice),- ("<", toOObj ((<) :: ℝ -> ℝ -> Bool) ),- (">", toOObj ((>) :: ℝ -> ℝ -> Bool) ),- (">=", toOObj ((>=) :: ℝ -> ℝ -> Bool) ),- ("<=", toOObj ((<=) :: ℝ -> ℝ -> Bool) ),- ("==", toOObj ((==) :: OVal -> OVal -> Bool) ),- ("!=", toOObj ((/=) :: OVal -> OVal -> Bool) ),- ("?", toOObj ( ternary :: Bool -> OVal -> OVal -> OVal) ),- ("&&", toOObj (&&) ),- ("||", toOObj (||) ),- ("!", toOObj not ),- ("list_gen", toOObj list_gen),- ("++", concat),- ("len", toOObj olength),- ("str", toOObj (show :: OVal -> String))- ] where+ [ + ("+", sum),+ ("sum", sum),+ ("*", prod),+ ("prod", prod),+ ("/", div),+ ("-", toOObj sub), + ("^", toOObj ((**) :: ℝ -> ℝ -> ℝ)), + ("negate", toOObj negate),+ ("index", toOObj index),+ ("splice", toOObj osplice),+ ("<", toOObj ((<) :: ℝ -> ℝ -> Bool) ),+ (">", toOObj ((>) :: ℝ -> ℝ -> Bool) ),+ (">=", toOObj ((>=) :: ℝ -> ℝ -> Bool) ),+ ("<=", toOObj ((<=) :: ℝ -> ℝ -> Bool) ),+ ("==", toOObj ((==) :: OVal -> OVal -> Bool) ),+ ("!=", toOObj ((/=) :: OVal -> OVal -> Bool) ),+ ("?", toOObj ( ternary :: Bool -> OVal -> OVal -> OVal) ),+ ("&&", toOObj (&&) ),+ ("||", toOObj (||) ),+ ("!", toOObj not ),+ ("list_gen", toOObj list_gen),+ ("++", concat),+ ("len", toOObj olength),+ ("str", toOObj (show :: OVal -> String))+ ] where - -- Some key functions are written as OVals in optimizations attempts+ -- Some key functions are written as OVals in optimizations attempts - prod = OFunc $ \x -> case x of- (OList (x:xs)) -> foldl mult x xs- (OList []) -> ONum 1- a -> OError ["Product takes a list"]+ prod = OFunc $ \x -> case x of+ (OList (x:xs)) -> foldl mult x xs+ (OList []) -> ONum 1+ a -> OError ["Product takes a list"] - mult (ONum a) (ONum b) = ONum (a*b)- mult (ONum a) (OList b) = OList (map (mult (ONum a)) b)- mult (OList a) (ONum b) = OList (map (mult (ONum b)) a)- mult a b = errorAsAppropriate "multiply" a b+ mult (ONum a) (ONum b) = ONum (a*b)+ mult (ONum a) (OList b) = OList (map (mult (ONum a)) b)+ mult (OList a) (ONum b) = OList (map (mult (ONum b)) a)+ mult a b = errorAsAppropriate "multiply" a b - div = OFunc $ \x -> case x of- (ONum a) -> OFunc $ \y -> case y of- (ONum b) -> ONum (a/b)- b -> errorAsAppropriate "divide" (ONum a) b- a -> OFunc $ \y -> case y of- b -> div' a b+ div = OFunc $ \x -> case x of+ (ONum a) -> OFunc $ \y -> case y of+ (ONum b) -> ONum (a/b)+ b -> errorAsAppropriate "divide" (ONum a) b+ a -> OFunc $ \y -> case y of+ b -> div' a b - div' (ONum a) (ONum b) = ONum (a/b)- div' (OList a) (ONum b) = OList (map (\x -> div' x (ONum b)) a)- div' a b = errorAsAppropriate "divide" a b+ div' (ONum a) (ONum b) = ONum (a/b)+ div' (OList a) (ONum b) = OList (map (\x -> div' x (ONum b)) a)+ div' a b = errorAsAppropriate "divide" a b - omod (ONum a) (ONum b) = ONum $ fromIntegral $ mod (floor a) (floor b)- omod a b = errorAsAppropriate "modulo" a b+ omod (ONum a) (ONum b) = ONum $ fromIntegral $ mod (floor a) (floor b)+ omod a b = errorAsAppropriate "modulo" a b - append (OList a) (OList b) = OList $ a++b- append (OString a) (OString b) = OString $ a++b- append a b = errorAsAppropriate "append" a b+ append (OList a) (OList b) = OList $ a++b+ append (OString a) (OString b) = OString $ a++b+ append a b = errorAsAppropriate "append" a b - concat = OFunc $ \x -> case x of- (OList (x:xs)) -> foldl append x xs- (OList []) -> OList []- _ -> OError ["concat takes a list"]+ concat = OFunc $ \x -> case x of+ (OList (x:xs)) -> foldl append x xs+ (OList []) -> OList []+ _ -> OError ["concat takes a list"] - sum = OFunc $ \x -> case x of- (OList (x:xs)) -> foldl add x xs- (OList []) -> ONum 0- a -> OError ["Product takes a list"]+ sum = OFunc $ \x -> case x of+ (OList (x:xs)) -> foldl add x xs+ (OList []) -> ONum 0+ a -> OError ["Product takes a list"] - add (ONum a) (ONum b) = ONum (a+b)- add (OList a) (OList b) = OList $ zipWith add a b- add a b = errorAsAppropriate "add" a b+ add (ONum a) (ONum b) = ONum (a+b)+ add (OList a) (OList b) = OList $ zipWith add a b+ add a b = errorAsAppropriate "add" a b - sub (ONum a) (ONum b) = ONum (a-b)- sub (OList a) (OList b) = OList $ zipWith sub a b- sub a b = errorAsAppropriate "subtract" a b+ sub (ONum a) (ONum b) = ONum (a-b)+ sub (OList a) (OList b) = OList $ zipWith sub a b+ sub a b = errorAsAppropriate "subtract" a b - negate (ONum n) = ONum (-n)- negate (OList l) = OList $ map negate l- negate a = OError ["Can't negate " ++ oTypeStr a ++ "(" ++ show a ++ ")"]+ negate (ONum n) = ONum (-n)+ negate (OList l) = OList $ map negate l+ negate a = OError ["Can't negate " ++ oTypeStr a ++ "(" ++ show a ++ ")"] - {-numCompareToExprCompare :: (ℝ -> ℝ -> Bool) -> Oval -> OVal -> Bool- numCompareToExprCompare f a b =- case (fromOObj a :: Maybe ℝ, fromOObj b :: Maybe ℝ) of- (Just a, Just b) -> f a b- _ -> False-}+ {-numCompareToExprCompare :: (ℝ -> ℝ -> Bool) -> Oval -> OVal -> Bool+ numCompareToExprCompare f a b =+ case (fromOObj a :: Maybe ℝ, fromOObj b :: Maybe ℝ) of+ (Just a, Just b) -> f a b+ _ -> False-} - index (OList l) (ONum ind) = - let n = floor ind - in if n < length l then l !! n else OError ["List accessd out of bounds"]- index (OString s) (ONum ind) = - let n = floor ind - in if n < length s then OString [s !! n] else OError ["List accessd out of bounds"]- index a b = errorAsAppropriate "index" a b+ index (OList l) (ONum ind) = + let n = floor ind + in if n < length l then l !! n else OError ["List accessd out of bounds"]+ index (OString s) (ONum ind) = + let n = floor ind + in if n < length s then OString [s !! n] else OError ["List accessd out of bounds"]+ index a b = errorAsAppropriate "index" a b - osplice (OList list) (ONum a) ( ONum b ) = - OList $ splice list (floor a) (floor b)- osplice (OString str) (ONum a) ( ONum b ) = - OString $ splice str (floor a) (floor b)- osplice (OList list) (OUndefined) (ONum b ) = - OList $ splice list 0 (floor b)- osplice (OString str) (OUndefined) (ONum b ) = - OString $ splice str 0 (floor b)- osplice (OList list) (ONum a) ( OUndefined) = - OList $ splice list (floor a) (length list + 1)- osplice (OString str) (ONum a) ( OUndefined) = - OString $ splice str (floor a) (length str + 1)- osplice (OList list) (OUndefined) (OUndefined) = - OList $ splice list 0 (length list + 1)- osplice (OString str) (OUndefined) (OUndefined) = - OString $ splice str 0 (length str + 1)- osplice _ _ _ = OUndefined+ osplice (OList list) (ONum a) ( ONum b ) = + OList $ splice list (floor a) (floor b)+ osplice (OString str) (ONum a) ( ONum b ) = + OString $ splice str (floor a) (floor b)+ osplice (OList list) (OUndefined) (ONum b ) = + OList $ splice list 0 (floor b)+ osplice (OString str) (OUndefined) (ONum b ) = + OString $ splice str 0 (floor b)+ osplice (OList list) (ONum a) ( OUndefined) = + OList $ splice list (floor a) (length list + 1)+ osplice (OString str) (ONum a) ( OUndefined) = + OString $ splice str (floor a) (length str + 1)+ osplice (OList list) (OUndefined) (OUndefined) = + OList $ splice list 0 (length list + 1)+ osplice (OString str) (OUndefined) (OUndefined) = + OString $ splice str 0 (length str + 1)+ osplice _ _ _ = OUndefined - splice :: [a] -> Int -> Int -> [a]- splice [] _ _ = []- splice (l@(x:xs)) a b - | a < 0 = splice l (a+n) b- | b < 0 = splice l a (b+n)- | a > 0 = splice xs (a-1) (b-1)- | b > 0 = x:(splice xs a (b-1) )- | otherwise = []- where n = length l+ splice :: [a] -> Int -> Int -> [a]+ splice [] _ _ = []+ splice (l@(x:xs)) a b + | a < 0 = splice l (a+n) b+ | b < 0 = splice l a (b+n)+ | a > 0 = splice xs (a-1) (b-1)+ | b > 0 = x:(splice xs a (b-1) )+ | otherwise = []+ where n = length l - errorAsAppropriate _ err@(OError _) _ = err- errorAsAppropriate _ _ err@(OError _) = err- errorAsAppropriate name a b = OError - ["Can't " ++ name ++ " objects of types " ++ oTypeStr a ++ " and " ++ oTypeStr b ++ "."]+ errorAsAppropriate _ err@(OError _) _ = err+ errorAsAppropriate _ _ err@(OError _) = err+ errorAsAppropriate name a b = OError + ["Can't " ++ name ++ " objects of types " ++ oTypeStr a ++ " and " ++ oTypeStr b ++ "."] - list_gen :: [ℝ] -> Maybe [ℝ]- list_gen [a,b] = Just [fromIntegral (ceiling a).. fromIntegral (floor b)]- list_gen [a, b, c] =- let- nr = (c-a)/b- n = fromIntegral (floor nr)- in if nr - n > 0- then Just - [fromIntegral (ceiling a), fromIntegral (ceiling (a+b)).. fromIntegral (floor (c - b*(nr -n)))]- else Just - [fromIntegral (ceiling a), fromIntegral (ceiling (a+b)).. fromIntegral (floor c)]- list_gen _ = Nothing+ list_gen :: [ℝ] -> Maybe [ℝ]+ list_gen [a,b] = Just [fromIntegral (ceiling a).. fromIntegral (floor b)]+ list_gen [a, b, c] =+ let+ nr = (c-a)/b+ n = fromIntegral (floor nr)+ in if nr - n > 0+ then Just + [fromIntegral (ceiling a), fromIntegral (ceiling (a+b)).. fromIntegral (floor (c - b*(nr -n)))]+ else Just + [fromIntegral (ceiling a), fromIntegral (ceiling (a+b)).. fromIntegral (floor c)]+ list_gen _ = Nothing - ternary True a b = a- ternary False a b = b+ ternary True a b = a+ ternary False a b = b - olegnth (OString s) = ONum $ fromIntegral $ length s- olength (OList s) = ONum $ fromIntegral $ length s- olength a = OError ["Can't take length of a " ++ oTypeStr a ++ "."]+ olegnth (OString s) = ONum $ fromIntegral $ length s+ olength (OList s) = ONum $ fromIntegral $ length s+ olength a = OError ["Can't take length of a " ++ oTypeStr a ++ "."]
Graphics/Implicit/ExtOpenScad/Definitions.hs view
@@ -12,17 +12,17 @@ | ListP [Pattern] | Wild | Symbol :@ Pattern- deriving Show+ deriving Show data Expr = Var Symbol | LitE OVal | ListE [Expr] | LamE [Pattern] Expr | Expr :$ [Expr]- deriving Show+ deriving Show data StatementI = StatementI Int (Statement StatementI)- deriving Show+ deriving Show data Statement st = Include String Bool | Pattern := Expr@@ -32,40 +32,40 @@ | NewModule Symbol [(Symbol, Maybe Expr)] [st] | ModuleCall Symbol [(Maybe Symbol, Expr)] [st] | DoNothing- deriving Show+ deriving Show -- | Objects for our OpenSCAD-like language data OVal = OUndefined | OError [String]- | OBool Bool - | ONum ℝ- | OList [OVal]- | OString String- | OFunc (OVal -> OVal)+ | OBool Bool + | ONum ℝ+ | OList [OVal]+ | OString String+ | OFunc (OVal -> OVal) | OModule ([OVal] -> ArgParser (IO [OVal])) | OObj3 SymbolicObj3 | OObj2 SymbolicObj2 instance Eq OVal where- (OBool a) == (OBool b) = a == b- (ONum a) == (ONum b) = a == b- (OList a) == (OList b) = all id $ zipWith (==) a b- (OString a) == (OString b) = a == b- _ == _ = False+ (OBool a) == (OBool b) = a == b+ (ONum a) == (ONum b) = a == b+ (OList a) == (OList b) = all id $ zipWith (==) a b+ (OString a) == (OString b) = a == b+ _ == _ = False instance Show OVal where- show OUndefined = "Undefined"- show (OBool b) = show b- show (ONum n) = show n- show (OList l) = show l- show (OString s) = show s- show (OFunc f) = "<function>"- show (OModule _) = "module"- show (OError msgs) = "Execution Error:\n" ++ foldl1 (\a b -> a ++ "\n" ++ b) msgs- show (OObj2 obj) = "<obj2: " ++ show obj ++ ">"- show (OObj3 obj) = "<obj3: " ++ show obj ++ ">"+ show OUndefined = "Undefined"+ show (OBool b) = show b+ show (ONum n) = show n+ show (OList l) = show l+ show (OString s) = show s+ show (OFunc f) = "<function>"+ show (OModule _) = "module"+ show (OError msgs) = "Execution Error:\n" ++ foldl1 (\a b -> a ++ "\n" ++ b) msgs+ show (OObj2 obj) = "<obj2: " ++ show obj ++ ">"+ show (OObj3 obj) = "<obj3: " ++ show obj ++ ">" type VarLookup = Map String OVal type FStack = [OVal]@@ -91,8 +91,7 @@ | APTest String [TestInvariant] (ArgParser a) -- A branch where there are a number of possibilities for the parser underneath | APBranch [ArgParser a]- deriving (Show) data TestInvariant = EulerCharacteristic Int - deriving (Show)+ deriving (Show)
Graphics/Implicit/ExtOpenScad/Eval/Expr.hs view
@@ -24,76 +24,76 @@ patMatch :: Pattern -> OVal -> Maybe [OVal] patMatch (Name _) val = Just [val] patMatch (ListP pats) (OList vals) = do- matches <- Monad.zipWithM patMatch pats vals- return $ concat matches+ matches <- Monad.zipWithM patMatch pats vals+ return $ concat matches patMatch Wild _ = Just [] patMatch _ _ = Nothing matchPat :: Pattern -> OVal -> Maybe VarLookup matchPat pat val = do- let vars = patVars pat- vals <- patMatch pat val- return $ Map.fromList $ zip vars vals+ let vars = patVars pat+ vals <- patMatch pat val+ return $ Map.fromList $ zip vars vals evalExpr :: Expr -> StateC OVal evalExpr expr = do- varlookup <- getVarLookup- (valf, _) <- liftIO $ State.runStateT (evalExpr' expr) (varlookup, [])- return $ valf []+ varlookup <- getVarLookup+ (valf, _) <- liftIO $ State.runStateT (evalExpr' expr) (varlookup, [])+ return $ valf [] evalExpr' :: Expr -> StateT (VarLookup, [String]) IO ([OVal] -> OVal) evalExpr' (Var name ) = do- (varlookup, namestack) <- get- return $- case (Map.lookup name varlookup, List.findIndex (==name) namestack) of- (_, Just pos) -> \s -> s !! pos- (Just val, _) -> const val- _ -> const $ OError ["Variable " ++ name ++ " not in scope" ] + (varlookup, namestack) <- get+ return $+ case (Map.lookup name varlookup, List.findIndex (==name) namestack) of+ (_, Just pos) -> \s -> s !! pos+ (Just val, _) -> const val+ _ -> const $ OError ["Variable " ++ name ++ " not in scope" ] evalExpr' (LitE val ) = return $ const val evalExpr' (ListE exprs) = do- valFuncs <- Monad.mapM evalExpr' exprs- return $ \s -> OList $ map ($s) valFuncs+ valFuncs <- Monad.mapM evalExpr' exprs+ return $ \s -> OList $ map ($s) valFuncs evalExpr' (fexpr :$ argExprs) = do- fValFunc <- evalExpr' fexpr- argValFuncs <- Monad.mapM evalExpr' argExprs- return $ \s -> app (fValFunc s) (map ($s) argValFuncs)- where - app f l = case (getErrors f, getErrors $ OList l) of- (Nothing, Nothing) -> app' f l where- app' (OFunc f) (x:xs) = app (f x) xs- app' a [] = a- app' x _ = OError ["Can't apply arguments to " ++ oTypeStr x]- (Just err, _ ) -> OError [err]- (_, Just err) -> OError [err]+ fValFunc <- evalExpr' fexpr+ argValFuncs <- Monad.mapM evalExpr' argExprs+ return $ \s -> app (fValFunc s) (map ($s) argValFuncs)+ where + app f l = case (getErrors f, getErrors $ OList l) of+ (Nothing, Nothing) -> app' f l where+ app' (OFunc f) (x:xs) = app (f x) xs+ app' a [] = a+ app' x _ = OError ["Can't apply arguments to " ++ oTypeStr x]+ (Just err, _ ) -> OError [err]+ (_, Just err) -> OError [err] evalExpr' (LamE pats fexpr) = do- fparts <- Monad.forM pats $ \pat -> do- modify (\(vl, names) -> (vl, patVars pat ++ names))- return $ \f xss -> OFunc $ \val -> case patMatch pat val of- Just xs -> f (xs ++ xss)- Nothing -> OError ["Pattern match failed"]- fval <- evalExpr' fexpr- return $ foldr ($) fval fparts+ fparts <- Monad.forM pats $ \pat -> do+ modify (\(vl, names) -> (vl, patVars pat ++ names))+ return $ \f xss -> OFunc $ \val -> case patMatch pat val of+ Just xs -> f (xs ++ xss)+ Nothing -> OError ["Pattern match failed"]+ fval <- evalExpr' fexpr+ return $ foldr ($) fval fparts -------------- simplifyExpr ((simplifyExpr -> Var f) :$ args) = (Var f :$) $- let- split b l = (filter b l, filter (not.b) l)- args' = map simplifyExpr args- (numArgs, nonNumArgs) = split (\x -> case x of LitE (ONum n) -> True; _ -> False) args'- numArgs' = map (\(LitE (ONum n)) -> n) numArgs- in case f of- "+" -> (LitE $ ONum $ sum numArgs'):nonNumArgs- "*" -> (LitE $ ONum $ product numArgs'):nonNumArgs- _ -> args'+ let+ split b l = (filter b l, filter (not.b) l)+ args' = map simplifyExpr args+ (numArgs, nonNumArgs) = split (\x -> case x of LitE (ONum n) -> True; _ -> False) args'+ numArgs' = map (\(LitE (ONum n)) -> n) numArgs+ in case f of+ "+" -> (LitE $ ONum $ sum numArgs'):nonNumArgs+ "*" -> (LitE $ ONum $ product numArgs'):nonNumArgs+ _ -> args' simplifyExpr x = x
Graphics/Implicit/ExtOpenScad/Eval/Statement.hs view
@@ -24,106 +24,106 @@ runStatementI :: StatementI -> StateC () runStatementI (StatementI lineN (pat := expr)) = do- val <- evalExpr expr- let posMatch = matchPat pat val- case (getErrors val, posMatch) of- (Just err, _ ) -> errorC lineN err- (_, Just match) -> modifyVarLookup $ Map.union match- (_, Nothing ) -> errorC lineN "pattern match failed in assignment"+ val <- evalExpr expr+ let posMatch = matchPat pat val+ case (getErrors val, posMatch) of+ (Just err, _ ) -> errorC lineN err+ (_, Just match) -> modifyVarLookup $ Map.union match+ (_, Nothing ) -> errorC lineN "pattern match failed in assignment" runStatementI (StatementI lineN (Echo exprs)) = do- let- show2 (OString s) = s- show2 x = show x- vals <- mapM evalExpr exprs- case getErrors (OList vals) of- Nothing -> liftIO $ putStrLn $ concat $ map show2 vals- Just err -> errorC lineN err+ let+ show2 (OString s) = s+ show2 x = show x+ vals <- mapM evalExpr exprs+ case getErrors (OList vals) of+ Nothing -> liftIO $ putStrLn $ concat $ map show2 vals+ Just err -> errorC lineN err runStatementI (StatementI lineN (For pat expr loopContent)) = do- val <- evalExpr expr- case (getErrors val, val) of- (Just err, _) -> errorC lineN err- (_, OList vals) -> Monad.forM_ vals $ \v ->- case matchPat pat v of- Just match -> do- modifyVarLookup $ Map.union match- runSuite loopContent- Nothing -> return ()- _ -> return ()+ val <- evalExpr expr+ case (getErrors val, val) of+ (Just err, _) -> errorC lineN err+ (_, OList vals) -> Monad.forM_ vals $ \v ->+ case matchPat pat v of+ Just match -> do+ modifyVarLookup $ Map.union match+ runSuite loopContent+ Nothing -> return ()+ _ -> return () runStatementI (StatementI lineN (If expr a b)) = do- val <- evalExpr expr- case (getErrors val, val) of- (Just err, _ ) -> errorC lineN ("In conditional expression of if statement: " ++ err)- (_, OBool True ) -> runSuite a- (_, OBool False) -> runSuite b- _ -> return ()+ val <- evalExpr expr+ case (getErrors val, val) of+ (Just err, _ ) -> errorC lineN ("In conditional expression of if statement: " ++ err)+ (_, OBool True ) -> runSuite a+ (_, OBool False) -> runSuite b+ _ -> return () runStatementI (StatementI lineN (NewModule name argTemplate suite)) = do- argTemplate' <- Monad.forM argTemplate $ \(name, defexpr) -> do- defval <- mapMaybeM evalExpr defexpr - return (name, defval)- (varlookup, _, path, _, _) <- get- runStatementI $ StatementI lineN $ (Name name :=) $ LitE $ OModule $ \vals -> do - newNameVals <- Monad.forM argTemplate' $ \(name, maybeDef) -> do- val <- case maybeDef of- Just def -> argument name `defaultTo` def- Nothing -> argument name- return (name, val)- let- children = ONum $ fromIntegral $ length vals- child = OModule $ \vals -> do- n :: ℕ <- argument "n";- return $ return $ return $ - if n <= length vals- then vals !! n- else OUndefined- childBox = OFunc $ \n -> case fromOObj n :: Maybe ℕ of- Just n | n < length vals -> case vals !! n of- -- _ -> toOObj $ getBox3 obj3- -- _ -> toOObj $ getBox2 obj2- _ -> OUndefined- _ -> OUndefined- newNameVals' = newNameVals ++ [("children", children),("child", child), ("childBox", childBox)]- varlookup' = Map.union (Map.fromList newNameVals) varlookup- suiteVals = runSuiteCapture varlookup' path suite- return suiteVals+ argTemplate' <- Monad.forM argTemplate $ \(name, defexpr) -> do+ defval <- mapMaybeM evalExpr defexpr + return (name, defval)+ (varlookup, _, path, _, _) <- get+ runStatementI $ StatementI lineN $ (Name name :=) $ LitE $ OModule $ \vals -> do + newNameVals <- Monad.forM argTemplate' $ \(name, maybeDef) -> do+ val <- case maybeDef of+ Just def -> argument name `defaultTo` def+ Nothing -> argument name+ return (name, val)+ let+ children = ONum $ fromIntegral $ length vals+ child = OModule $ \vals -> do+ n :: ℕ <- argument "n";+ return $ return $ return $ + if n <= length vals+ then vals !! n+ else OUndefined+ childBox = OFunc $ \n -> case fromOObj n :: Maybe ℕ of+ Just n | n < length vals -> case vals !! n of+ -- _ -> toOObj $ getBox3 obj3+ -- _ -> toOObj $ getBox2 obj2+ _ -> OUndefined+ _ -> OUndefined+ newNameVals' = newNameVals ++ [("children", children),("child", child), ("childBox", childBox)]+ varlookup' = Map.union (Map.fromList newNameVals) varlookup+ suiteVals = runSuiteCapture varlookup' path suite+ return suiteVals runStatementI (StatementI lineN (ModuleCall name argsExpr suite)) = do- maybeMod <- lookupVar name- (varlookup, _, path, _, _) <- get- childVals <- fmap reverse $ liftIO $ runSuiteCapture varlookup path suite- argsVal <- Monad.forM argsExpr $ \(posName, expr) -> do- val <- evalExpr expr- return (posName, val)- newVals <- case maybeMod of- Just (OModule mod) -> liftIO ioNewVals where- argparser = mod childVals- ioNewVals = case fst $ argMap argsVal argparser of- Just iovals -> iovals- Nothing -> return []- Just foo -> do- case getErrors foo of- Just err -> errorC lineN err- Nothing -> errorC lineN $ "Object called not module!"- return []- Nothing -> do- errorC lineN $ "Module " ++ name ++ " not in scope."- return []- pushVals newVals+ maybeMod <- lookupVar name+ (varlookup, _, path, _, _) <- get+ childVals <- fmap reverse $ liftIO $ runSuiteCapture varlookup path suite+ argsVal <- Monad.forM argsExpr $ \(posName, expr) -> do+ val <- evalExpr expr+ return (posName, val)+ newVals <- case maybeMod of+ Just (OModule mod) -> liftIO ioNewVals where+ argparser = mod childVals+ ioNewVals = case fst $ argMap argsVal argparser of+ Just iovals -> iovals+ Nothing -> return []+ Just foo -> do+ case getErrors foo of+ Just err -> errorC lineN err+ Nothing -> errorC lineN $ "Object called not module!"+ return []+ Nothing -> do+ errorC lineN $ "Module " ++ name ++ " not in scope."+ return []+ pushVals newVals runStatementI (StatementI lineN (Include name injectVals)) = do- name' <- getRelPath name- content <- liftIO $ readFile name'- case parseProgram name content of- Left e -> liftIO $ putStrLn $ "Error parsing " ++ name ++ ":" ++ show e- Right sts -> withPathShiftedBy (FilePath.takeDirectory name) $ do- vals <- getVals- putVals []- runSuite sts- vals' <- getVals- if injectVals then putVals (vals' ++ vals) else putVals vals+ name' <- getRelPath name+ content <- liftIO $ readFile name'+ case parseProgram name content of+ Left e -> liftIO $ putStrLn $ "Error parsing " ++ name ++ ":" ++ show e+ Right sts -> withPathShiftedBy (FilePath.takeDirectory name) $ do+ vals <- getVals+ putVals []+ runSuite sts+ vals' <- getVals+ if injectVals then putVals (vals' ++ vals) else putVals vals @@ -132,10 +132,10 @@ runSuiteCapture :: VarLookup -> FilePath -> [StatementI] -> IO [OVal] runSuiteCapture varlookup path suite = do- (res, state) <- State.runStateT - (runSuite suite >> getVals)- (varlookup, [], path, (), () )- return res+ (res, state) <- State.runStateT + (runSuite suite >> getVals)+ (varlookup, [], path, (), () )+ return res
Graphics/Implicit/ExtOpenScad/Parser/Expr.hs view
@@ -10,235 +10,206 @@ variable = fmap Var variableSymb literal :: GenParser Char st Expr-literal = - try ( (string "true" >> return (LitE $ OBool True) )- <|> (string "false" >> return (LitE $ OBool False) )- <?> "boolean" )- <|> try ( try (do- a <- many1 digit- char '.'- b <- many digit- return $ LitE $ ONum (read (a ++ "." ++ b) :: ℝ)- ) <|> (do- a <- many1 digit- return $ LitE $ ONum (read a :: ℝ)- ) <?> "number" )- <|> try ( ( do- string "\""- strlit <- many $ try (string "\\\"" >> return '\"') <|> try (string "\\n" >> return '\n') <|> ( noneOf "\"\n")- string "\""- return $ LitE $ OString strlit- ) <?> "string" )- <?> "literal"+literal = ("literal" ?:) $+ "boolean" ?: do+ b <- (string "true" >> return True )+ *<|> (string "false" >> return False)+ return $ LitE $ OBool b+ *<|> "number" ?: (+ do+ a <- many1 digit+ char '.'+ b <- many digit+ return $ LitE $ ONum (read (a ++ "." ++ b) :: ℝ)+ *<|> do+ a <- many1 digit+ return $ LitE $ ONum (read a :: ℝ)+ )+ *<|> "string" ?: do+ string "\""+ strlit <- many $ (string "\\\"" >> return '\"') + *<|> (string "\\n" >> return '\n')+ *<|> ( noneOf "\"\n")+ string "\""+ return $ LitE $ OString strlit -- We represent the priority or 'fixity' of different types of expressions -- by the Int argument -expression :: Int -> GenParser Char st Expr-expression n@12 = (try literal) <|> (try variable )- <|> (try (do -- ( 1 + 5 )- string "("- expr <- expression 0- string ")"- return expr- ) <?> "bracketed expression" )- <|> ( try ( do -- [ 3, a, a+1, b, a*b ]- string "["- exprs <- sepBy (expression 0) (char ',' )- string "]"- return $ ListE exprs- )<|> try ( do -- ( 1,2,3 )- string "("- exprs <- sepBy (expression 0) (char ',' )- string ")"- return $ ListE exprs- ) <|> ( do -- eg. [ a : 1 : a + 10 ]- string "["- exprs <- sepBy (expression 0) (char ':' )- string "]"- return $ collector "list_gen" exprs- )<?> "vector/list" )-expression n@11 = - let- posMatch a =- (try $ do- x <- a- return $ Just x- ) <|> (return Nothing)- modifier = - (try $ (do- genSpace- string "("- genSpace- args <- sepBy - (expression 0) - (try $ genSpace >> char ',' >> genSpace)- genSpace- string ")"- genSpace- return $ \f -> f :$ args- <?> "function application"- )) <|> (try $ (do- genSpace- string "["- i <- pad $ expression 0- string "]"- genSpace- return $ \l -> Var "index" :$ [l, i]- <?> "list indexing"- )) <|> (try $ ( do- string "["- genSpace- start <- posMatch $ expression 0- genSpace- char ':'- genSpace- end <- posMatch $ expression 0- genSpace- string "]"- return $ case (start, end) of- (Nothing, Nothing) -> id- (Just s, Nothing) -> \l -> Var "splice" :$ [l, s, LitE OUndefined ]- (Nothing, Just e ) -> \l -> Var "splice" :$ [l, LitE $ ONum 0, e]- (Just s, Just e ) -> \l -> Var "splice" :$ [l, s, e]- <?> "list splicing"))- - in ( try( do - obj <- expression $ n+1- genSpace- mods <- modifier `sepBy` (genSpace)- genSpace- return $ foldl (\a b -> b a) obj mods- ) <?> "list splicing" )- <|> try (expression $ n+1 )-expression n@10 = - let- negate x = Var "negate" :$ [x]- in try (do- char '-'- genSpace- expr <- expression $ n+1- return $ negate expr- ) <|> try (do- char '+'- genSpace- expr <- expression $ n+1- return expr- ) <|> try (expression $ n+1)-expression n@9 = try (( do - a <- expression (n+1)- genSpace- string "^"- genSpace- b <- expression n;- return $ Var "^" :$ [a,b]- ) <?> "exponentiation")- <|> try (expression $ n+1)-expression n@8 = - let - div a b = Var "/" :$ [a, b]- in try (( do - -- outer list is multiplication, inner division. objects are - -- expressions and take a varlookup to evaluate.- -- eg. "1*2*3/4/5*6*7/8"- -- [[vl→1],[vl→2],[vl→3,vl→4,vl→5],[vl→6],[vl→7,vl→8]]- exprs <- sepBy1 (sepBy1 (pad $ expression $ n+1) - (try $ genSpace >> char '/' >> genSpace )) - (try $ genSpace >> char '*' >> genSpace)- -- [[1],[2],[3,4,5],[6],[7,8]]- -- [ 1, 2, 3/4/5, 6, 7/8 ]- -- 1 * 2 * 3/4/5 * 6 * 7/8 - return $ collector "*" $ map (foldl1 div) exprs- ) <?> "multiplication/division")- <|>try (expression $ n+1)-expression n@7 =- let - mod a b = Var "%" :$ [a, b]- in try (( do - exprs <- sepBy1 (expression $ n+1) (try $ genSpace >> string "%" >> genSpace)- return $ foldl1 mod exprs- ) <?> "modulo") - <|>try (expression $ n+1)-expression n@6 =- try (( do - exprs <- sepBy1 (expression $ n+1) (try $ genSpace >> string "++" >> genSpace)- return $ collector "++" exprs- ) <?> "append") - <|>try (expression $ n+1)+expr0 :: GenParser Char st Expr+expr0 = exprN 0 -expression n@5 =- let - sub a b = Var "-" :$ [a, b]- in try (( do - -- Similar to multiply & divide- -- eg. "1+2+3-4-5+6-7" - -- [[1],[2],[3,4,5],[6,7]]- exprs <- sepBy1 (sepBy1 (pad $ expression $ n+1) - (try $ genSpace >> char '-' >> genSpace )) - (try $ genSpace >> char '+' >> genSpace)- return $ collector "+" $ map (foldl1 sub) exprs- ) <?> "addition/subtraction")- <|>try (expression $ n+1)-expression n@4 = - try ( do- firstExpr <- expression $ n+1- otherComparisonsExpr <- many $ do- comparison <-- (try $ string "==" >> return (Var "==") )- <|> (try $ string "!=" >> return (Var "!=") )- <|> (try $ string ">=" >> return (Var ">=") )- <|> (try $ string "<=" >> return (Var "<=") )- <|> (try $ string ">" >> return (Var ">") )- <|> (try $ string "<" >> return (Var "<") )- expr <- expression $ n+1- return (comparison, expr) - let- (comparisons, otherExprs) = unzip otherComparisonsExpr- exprs = firstExpr:otherExprs- return $ case comparisons of - [] -> firstExpr- [x] -> x :$ exprs- _ -> collector "all" [(comparisons!!n) :$ [exprs!!n, exprs!!(n+1)] | n <- [0.. length comparisons - 1] ]- )<|> try (expression $ n+1)-expression n@3 =- try (( do- string "!"- genSpace- a <- expression $ n+1- return $ Var "!" :$ [a]- )<?> "logical-not")- <|> try (expression $ n+1)-expression n@2 = - try (( do - a <- expression (n+1)- genSpace- string "&&"- genSpace- b <- expression n- return $ Var "&&" :$ [a,b]- )<?> "logical-and")- <|> try (( do- a <- expression $ n+1- genSpace- string "||"- genSpace- b <- expression n- return $ Var "||" :$ [a,b]- )<?> "logical-or")- <|> try (expression $ n+1)-expression n@1 = - try (( do - a <- expression (n+1)- genSpace- string "?"- genSpace- b <- expression n- genSpace- string ":"- genSpace- c <- expression n- return $ Var "?" :$ [a,b,c]- ) <?> "ternary")- <|> try (expression $ n+1)-expression n@0 = try (do { genSpace; expr <- expression $ n+1; genSpace; return expr}) <|> try (expression $ n+1)+exprN :: Integer -> GenParser Char st Expr++exprN n@12 = + literal+ *<|> variable+ *<|> "bracketed expression" ?: do+ -- eg. ( 1 + 5 )+ string "("+ expr <- expr0+ string ")"+ return expr+ *<|> "vector/list" ?: (+ do+ -- eg. [ 3, a, a+1, b, a*b ]+ string "["+ exprs <- sepBy expr0 (char ',' )+ string "]"+ return $ ListE exprs+ *<|> do + -- eg. ( 1,2,3 )+ string "("+ exprs <- sepBy expr0 (char ',' )+ string ")"+ return $ ListE exprs+ )+ *<|> "vector/list generator" ?: do+ -- eg. [ a : 1 : a + 10 ]+ string "["+ exprs <- sepBy expr0 (char ':' )+ string "]"+ return $ collector "list_gen" exprs++exprN n@11 = + do+ obj <- exprN $ n+1+ genSpace+ mods <- many1 (+ "function application" ?: do+ padString "("+ args <- sepBy expr0 (padString ",")+ padString ")"+ return $ \f -> f :$ args+ *<|> "list indexing" ?: do+ padString "["+ i <- expr0+ padString "]"+ return $ \l -> Var "index" :$ [l, i]+ *<|> "list splicing" ?: do+ padString "["+ start <- optionMaybe expr0+ padString ":"+ end <- optionMaybe expr0+ padString "]"+ return $ case (start, end) of+ (Nothing, Nothing) -> id+ (Just s, Nothing) -> \l -> Var "splice" :$ [l, s, LitE OUndefined ]+ (Nothing, Just e ) -> \l -> Var "splice" :$ [l, LitE $ ONum 0, e]+ (Just s, Just e ) -> \l -> Var "splice" :$ [l, s, e]+ )+ return $ foldl (\a b -> b a) obj mods+ *<|> (exprN $ n+1 )++exprN n@10 = + "negation" ?: do+ padString "-"+ expr <- exprN $ n+1+ return $ Var "negate" :$ [expr]+ *<|> do+ padString "+"+ expr <- exprN $ n+1+ return expr+ *<|> exprN (n+1)++exprN n@9 = + "exponentiation" ?: do + a <- exprN $ n+1+ padString "^"+ b <- exprN n+ return $ Var "^" :$ [a,b]+ *<|> exprN (n+1)++exprN n@8 = + "multiplication/division" ?: do + -- outer list is multiplication, inner division.+ -- eg. "1*2*3/4/5*6*7/8"+ -- [[1],[2],[3,4,5],[6],[7,8]]+ exprs <- sepBy1 + (sepBy1 (exprN $ n+1) (try $ padString "/" )) + (try $ padString "*" )+ let div a b = Var "/" :$ [a, b]+ return $ collector "*" $ map (foldl1 div) exprs+ *<|> exprN (n+1)++exprN n@7 =+ "modulo" ?: do + exprs <- sepBy1 (exprN $ n+1) (try $ padString "%")+ let mod a b = Var "%" :$ [a, b]+ return $ foldl1 mod exprs + *<|> exprN (n+1)++exprN n@6 =+ "append" ?: do + exprs <- sepBy1 (exprN $ n+1) (try $ padString "++")+ return $ collector "++" exprs+ *<|> exprN (n+1)++exprN n@5 =+ "addition/subtraction" ?: do + -- Similar to multiply & divide+ -- eg. "1+2+3-4-5+6-7" + -- [[1],[2],[3,4,5],[6,7]]+ exprs <- sepBy1 + (sepBy1 (exprN $ n+1) (try $ padString "-" )) + (try $ padString "+" )+ let sub a b = Var "-" :$ [a, b]+ return $ collector "+" $ map (foldl1 sub) exprs+ *<|> exprN (n+1)++exprN n@4 = + do+ firstExpr <- exprN $ n+1+ otherComparisonsExpr <- many $ do+ comparisonSymb <-+ padString "=="+ *<|> padString "!="+ *<|> padString ">="+ *<|> padString "<="+ *<|> padString ">"+ *<|> padString "<"+ expr <- exprN $ n+1+ return (Var comparisonSymb, expr) + let+ (comparisons, otherExprs) = unzip otherComparisonsExpr+ exprs = firstExpr:otherExprs+ return $ case comparisons of + [] -> firstExpr+ [x] -> x :$ exprs+ _ -> collector "all" $ zipWith3 (\c e1 e2 -> c :$ [e1,e2]) comparisons exprs (tail exprs)+ *<|> exprN (n+1)++exprN n@3 =+ "logical-not" ?: do+ padString "!"+ a <- exprN $ n+1+ return $ Var "!" :$ [a]+ *<|> exprN (n+1)++exprN n@2 = + "logical and/or" ?: do + a <- exprN $ n+1+ symb <- padString "&&"+ *<|> padString "||"+ b <- exprN n+ return $ Var symb :$ [a,b]+ *<|> exprN (n+1)++exprN n@1 = + "ternary" ?: do + a <- exprN $ n+1+ padString "?"+ b <- exprN n+ padString ":"+ c <- exprN n+ return $ Var "?" :$ [a,b,c]+ *<|> exprN (n+1)++exprN n@0 = + do + genSpace+ expr <- exprN $ n+1+ genSpace+ return expr+ *<|> exprN (n+1)
Graphics/Implicit/ExtOpenScad/Parser/Statement.hs view
@@ -8,50 +8,47 @@ import Graphics.Implicit.ExtOpenScad.Parser.Expr parseProgram name s = parse program name s where- program = do- sts <- many1 computation- eof- return sts+ program = do+ sts <- many1 computation+ eof+ return sts -- | A in our programming openscad-like programming language. computation :: GenParser Char st StatementI computation = - (try $ do -- suite statemetns: no semicolon...- genSpace- s <- tryMany [- ifStatementI,- forStatementI,- throwAway,- userModuleDeclaration{-,- unimplemented "mirror",- unimplemented "multmatrix",- unimplemented "color",- unimplemented "render",- unimplemented "surface",- unimplemented "projection",- unimplemented "import_stl"-}- -- rotateExtrude- ]- genSpace- return s- ) <|> (try $ do -- Non suite s. Semicolon needed...- genSpace- s <- tryMany [- echo,- assignment,- include--,- --use- ]- genSpace- char ';'- genSpace- return s- ) <|> (try $ do- genSpace- s <- userModule- genSpace- return s- )+ do -- suite statemetns: no semicolon...+ genSpace+ s <- tryMany [+ ifStatementI,+ forStatementI,+ throwAway,+ userModuleDeclaration{-,+ unimplemented "mirror",+ unimplemented "multmatrix",+ unimplemented "color",+ unimplemented "render",+ unimplemented "surface",+ unimplemented "projection",+ unimplemented "import_stl"-}+ -- rotateExtrude+ ]+ genSpace+ return s+ *<|> do -- Non suite s. Semicolon needed...+ genSpace+ s <- tryMany [+ echo,+ assignment,+ include--,+ --use+ ]+ stringGS " ; "+ return s+ *<|> do+ genSpace+ s <- userModule+ genSpace+ return s {- -- | A suite of s!@@ -72,205 +69,164 @@ -} suite :: GenParser Char st [StatementI] suite = (fmap return computation <|> do - char '{'- genSpace- stmts <- many (try computation)- genSpace- char '}'- return stmts- ) <?> " suite"+ char '{'+ genSpace+ stmts <- many (try computation)+ genSpace+ char '}'+ return stmts+ ) <?> " suite" throwAway :: GenParser Char st StatementI throwAway = do- line <- lineNumber- genSpace- oneOf "%*"- genSpace- computation- return $ StatementI line DoNothing+ line <- lineNumber+ genSpace+ oneOf "%*"+ genSpace+ computation+ return $ StatementI line DoNothing -- An included ! Basically, inject another openscad file here... include :: GenParser Char st StatementI include = (do- line <- lineNumber- use <- (string "include" >> return False)- <|> (string "use" >> return True )- genSpace- string "<"- filename <- many (noneOf "<>")- string ">"- return $ StatementI line $ Include filename use- ) <?> "include "+ line <- lineNumber+ injectVals <- (string "include" >> return True )+ <|> (string "use" >> return False)+ stringGS " < "+ filename <- many (noneOf "<> ")+ stringGS " > "+ return $ StatementI line $ Include filename injectVals+ ) <?> "include " -- | An assignment (parser) assignment :: GenParser Char st StatementI-assignment = - (try $ do- line <- lineNumber- pattern <- patternMatcher- genSpace- char '='- genSpace- valExpr <- expression 0- return $ StatementI line$ pattern := valExpr- ) <|> (try $ do - line <- lineNumber- varSymb <- (try $ string "function" >> space >> genSpace >> variableSymb) - <|> variableSymb- genSpace- char '('- genSpace- argVars <- sepBy patternMatcher (try $ genSpace >> char ',' >> genSpace)- genSpace- char ')'- genSpace- char '='- genSpace- valExpr <- expression 0- return $ StatementI line $ Name varSymb := LamE argVars valExpr- )<?> "assignment "+assignment = ("assignment " ?:) $+ do+ line <- lineNumber+ pattern <- patternMatcher+ stringGS " = "+ valExpr <- expr0+ return $ StatementI line$ pattern := valExpr+ *<|> do+ line <- lineNumber+ varSymb <- (string "function" >> space >> genSpace >> variableSymb) + *<|> variableSymb+ stringGS " ( "+ argVars <- sepBy patternMatcher (stringGS " , ")+ stringGS " ) = "+ valExpr <- expr0+ return $ StatementI line $ Name varSymb := LamE argVars valExpr -- | An echo (parser) echo :: GenParser Char st StatementI echo = do- line <- lineNumber- string "echo"- genSpace- char '('- genSpace- exprs <- expression 0 `sepBy` (try $ genSpace >> char ',' >> genSpace)- genSpace- char ')'- return $ StatementI line $ Echo exprs+ line <- lineNumber+ stringGS " echo ( "+ exprs <- expr0 `sepBy` (stringGS " , ")+ stringGS " ) "+ return $ StatementI line $ Echo exprs ifStatementI :: GenParser Char st StatementI-ifStatementI = (do- line <- lineNumber- string "if"- genSpace- char '('- bexpr <- expression 0- char ')'- genSpace- sTrueCase <- suite- genSpace- sFalseCase <- try (string "else" >> genSpace >> suite ) <|> (return [])- return $ StatementI line $ If bexpr sTrueCase sFalseCase- ) <?> "if "+ifStatementI = + "if " ?: do+ line <- lineNumber+ stringGS "if ( "+ bexpr <- expr0+ stringGS " ) "+ sTrueCase <- suite+ genSpace+ sFalseCase <- (stringGS "else " >> suite ) *<|> (return [])+ return $ StatementI line $ If bexpr sTrueCase sFalseCase forStatementI :: GenParser Char st StatementI-forStatementI = (do- line <- lineNumber- -- a for loop is of the form:- -- for ( vsymb = vexpr ) loops- -- eg. for ( a = [1,2,3] ) {echo(a); echo "lol";}- -- eg. for ( [a,b] = [[1,2]] ) {echo(a+b); echo "lol";}- string "for"- genSpace- char '('- genSpace- pattern <- patternMatcher- genSpace- char '='- vexpr <- expression 0- char ')'- genSpace- loopContent <- suite- return $ StatementI line $ For pattern vexpr loopContent- ) <?> "for "+forStatementI =+ "for " ?: do+ line <- lineNumber+ -- a for loop is of the form:+ -- for ( vsymb = vexpr ) loops+ -- eg. for ( a = [1,2,3] ) {echo(a); echo "lol";}+ -- eg. for ( [a,b] = [[1,2]] ) {echo(a+b); echo "lol";}+ stringGS " for ( "+ pattern <- patternMatcher+ stringGS " = "+ vexpr <- expr0+ stringGS " ) "+ loopContent <- suite+ return $ StatementI line $ For pattern vexpr loopContent userModule :: GenParser Char st StatementI userModule = do- line <- lineNumber- name <- variableSymb;- genSpace;- args <- moduleArgsUnit- genSpace;- s <- ( try suite <|> (genSpace >> char ';' >> return []))- return $ StatementI line $ ModuleCall name args s+ line <- lineNumber+ name <- variableSymb+ genSpace+ args <- moduleArgsUnit+ genSpace+ s <- suite *<|> (stringGS " ; " >> return [])+ return $ StatementI line $ ModuleCall name args s userModuleDeclaration :: GenParser Char st StatementI userModuleDeclaration = do- line <- lineNumber- string "module"- genSpace;- newModuleName <- variableSymb;- genSpace;- args <- moduleArgsUnitDecl- genSpace;- s <- suite- return $ StatementI line $ NewModule newModuleName args s+ line <- lineNumber+ stringGS "module "+ newModuleName <- variableSymb+ genSpace+ args <- moduleArgsUnitDecl+ genSpace+ s <- suite+ return $ StatementI line $ NewModule newModuleName args s ---------------------- moduleArgsUnit :: GenParser Char st [(Maybe String, Expr)] moduleArgsUnit = do- char '(';- genSpace- args <- sepBy ( - (try $ do -- eg. a = 12- symb <- variableSymb- genSpace- char '='- genSpace- expr <- expression 0- return $ (Just symb, expr)- ) <|> (try $ do -- eg. a(x,y) = 12- symb <- variableSymb;- genSpace- char '('- genSpace- argVars <- sepBy variableSymb (try $ genSpace >> char ',' >> genSpace)- char ')'- genSpace- char '=';- genSpace- expr <- expression 0;- return $ (Just symb, LamE (map Name argVars) expr)- ) <|> (do { -- eg. 12- expr <- expression 0;- return (Nothing, expr)- })- ) (try $ genSpace >> char ',' >> genSpace)- genSpace - char ')'- return args+ stringGS " ( "+ args <- sepBy ( + do+ -- eg. a = 12+ symb <- variableSymb+ stringGS " = "+ expr <- expr0+ return $ (Just symb, expr)+ *<|> do+ -- eg. a(x,y) = 12+ symb <- variableSymb+ stringGS " ( "+ argVars <- sepBy variableSymb (try $ stringGS " , ")+ stringGS " ) = "+ expr <- expr0+ return $ (Just symb, LamE (map Name argVars) expr)+ *<|> do+ -- eg. 12+ expr <- expr0+ return (Nothing, expr)+ ) (try $ stringGS " , ")+ stringGS " ) "+ return args moduleArgsUnitDecl :: GenParser Char st [(String, Maybe Expr)] moduleArgsUnitDecl = do- char '(';- genSpace- argTemplate <- sepBy ( - (try $ do- symb <- variableSymb;- genSpace- char '='- genSpace- expr <- expression 0- return (symb, Just expr)- ) <|> (try $ do- symb <- variableSymb;- genSpace- char '('- genSpace- argVars <- sepBy variableSymb (try $ genSpace >> char ',' >> genSpace)- char ')'- genSpace- char '='- genSpace- expr <- expression 0- return (symb, Just expr)- ) <|> (do {- symb <- variableSymb;- return (symb, Nothing)- })- ) (try $ genSpace >> char ',' >> genSpace);- genSpace - char ')';- return argTemplate-+ stringGS " ( "+ argTemplate <- sepBy (+ do+ symb <- variableSymb;+ stringGS " = "+ expr <- expr0+ return (symb, Just expr)+ *<|> do+ symb <- variableSymb;+ stringGS " ( "+ argVars <- sepBy variableSymb (try $ stringGS " , ")+ stringGS " ) = "+ expr <- expr0+ return (symb, Just expr)+ *<|> do+ symb <- variableSymb+ return (symb, Nothing)+ ) (try $ stringGS " , ")+ stringGS " ) "+ return argTemplate lineNumber = fmap sourceLine getPosition
Graphics/Implicit/ExtOpenScad/Parser/Util.hs view
@@ -7,24 +7,46 @@ -- white space, including tabs, newlines and comments genSpace = many $ - oneOf " \t\n\r" - <|> (try $ do- string "//"- many ( noneOf "\n")- string "\n"- return ' '- ) <|> (try $ do- string "/*"- manyTill anyChar (try $ string "*/")- return ' '- )+ oneOf " \t\n\r" + <|> (try $ do+ string "//"+ many ( noneOf "\n")+ string "\n"+ return ' '+ ) <|> (try $ do+ string "/*"+ manyTill anyChar (try $ string "*/")+ return ' '+ ) pad parser = do- genSpace- a <- parser- genSpace- return a+ genSpace+ a <- parser+ genSpace+ return a +infixr 1 *<|>+a *<|> b = try a <|> b++infixr 2 ?:+l ?: p = p <?> l++stringGS (' ':xs) = do+ x' <- genSpace+ xs' <- stringGS xs+ return (x' ++ xs')+stringGS (x:xs) = do+ x' <- char x+ xs' <- stringGS xs+ return (x' : xs')+stringGS "" = return ""++padString s = do+ genSpace+ s' <- string s+ genSpace+ return s'+ tryMany = (foldl1 (<|>)) . (map try) variableSymb = many1 (noneOf " ,|[]{}()+-*&^%#@!~`'\"\\/;:.,<>?=") <?> "variable"@@ -32,26 +54,26 @@ patternMatcher :: GenParser Char st Pattern patternMatcher =- (do - char '_'- return Wild- ) <|> {-( do- a <- literal- return $ \obj ->- if obj == (a undefined)- then Just (Map.empty)- else Nothing- ) <|> -} ( do- symb <- variableSymb- return $ Name symb- ) <|> ( do- char '['- genSpace- components <- patternMatcher `sepBy` (try $ genSpace >> char ',' >> genSpace)- genSpace- char ']'- return $ ListP components- )+ (do + char '_'+ return Wild+ ) <|> {-( do+ a <- literal+ return $ \obj ->+ if obj == (a undefined)+ then Just (Map.empty)+ else Nothing+ ) <|> -} ( do+ symb <- variableSymb+ return $ Name symb+ ) <|> ( do+ char '['+ genSpace+ components <- patternMatcher `sepBy` (try $ genSpace >> char ',' >> genSpace)+ genSpace+ char ']'+ return $ ListP components+ )
Graphics/Implicit/ExtOpenScad/Primitives.hs view
@@ -7,7 +7,7 @@ -- The code is fairly straightforward; an explanation of how -- the first one works is provided. -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ScopedTypeVariables, OverlappingInstances #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ScopedTypeVariables #-} module Graphics.Implicit.ExtOpenScad.Primitives (primitives) where @@ -32,424 +32,427 @@ -- this means that the parser will look for this like -- sphere(args...); sphere = moduleWithoutSuite "sphere" $ do- example "sphere(3);"- example "sphere(r=5);"- -- What are the arguments?- -- The radius, r, which is a (real) number.- -- Because we don't provide a default, this ends right- -- here if it doesn't get a suitable argument!- r :: ℝ <- argument "r" - `doc` "radius of the sphere"- -- So what does this module do?- -- It adds a 3D object, a sphere of radius r,- -- using the sphere implementation in Prim- -- (Graphics.Implicit.Primitives)- addObj3 $ Prim.sphere r+ example "sphere(3);"+ example "sphere(r=5);"+ -- What are the arguments?+ -- The radius, r, which is a (real) number.+ -- Because we don't provide a default, this ends right+ -- here if it doesn't get a suitable argument!+ r :: ℝ <- argument "r" + `doc` "radius of the sphere"+ -- So what does this module do?+ -- It adds a 3D object, a sphere of radius r,+ -- using the sphere implementation in Prim+ -- (Graphics.Implicit.Primitives)+ addObj3 $ Prim.sphere r cube = moduleWithoutSuite "cube" $ do - -- examples- example "cube(size = [2,3,4], center = true, r = 0.5);"- example "cube(4);"+ -- examples+ example "cube(size = [2,3,4], center = true, r = 0.5);"+ example "cube(4);" - -- arguments- ((x1,x2), (y1,y2), (z1,z2)) <-- do- x :: Either ℝ ℝ2 <- argument "x"- `doc` "x or x-interval"- y :: Either ℝ ℝ2 <- argument "y"- `doc` "y or y-interval"- z :: Either ℝ ℝ2 <- argument "z"- `doc` "z or z-interval"- center :: Bool <- argument "center" - `doc` "should center? (non-intervals)" - `defaultTo` False- let toInterval' = toInterval center- return (either (toInterval center) id x,- either (toInterval center) id y,- either (toInterval center) id z)- <|> do- size :: Either ℝ ℝ3 <- argument "size"- `doc` "square size"- center :: Bool <- argument "center" - `doc` "should center?" - `defaultTo` False- let (x,y, z) = either (\w -> (w,w,w)) id size- return (toInterval center x, toInterval center y, toInterval center z)+ -- arguments+ ((x1,x2), (y1,y2), (z1,z2)) <-+ do+ x :: Either ℝ ℝ2 <- argument "x"+ `doc` "x or x-interval"+ y :: Either ℝ ℝ2 <- argument "y"+ `doc` "y or y-interval"+ z :: Either ℝ ℝ2 <- argument "z"+ `doc` "z or z-interval"+ center :: Bool <- argument "center" + `doc` "should center? (non-intervals)" + `defaultTo` False+ let toInterval' = toInterval center+ return (either (toInterval center) id x,+ either (toInterval center) id y,+ either (toInterval center) id z)+ <|> do+ size :: Either ℝ ℝ3 <- argument "size"+ `doc` "square size"+ center :: Bool <- argument "center" + `doc` "should center?" + `defaultTo` False+ let (x,y, z) = either (\w -> (w,w,w)) id size+ return (toInterval center x, toInterval center y, toInterval center z) - r :: ℝ <- argument "r"- `doc` "radius of rounding" - `defaultTo` 0+ r :: ℝ <- argument "r"+ `doc` "radius of rounding" + `defaultTo` 0 - -- Tests- test "cube(4);"- `eulerCharacteristic` 2- test "cube(size=[2,3,4]);"- `eulerCharacteristic` 2+ -- Tests+ test "cube(4);"+ `eulerCharacteristic` 2+ test "cube(size=[2,3,4]);"+ `eulerCharacteristic` 2 - addObj3 $ Prim.rect3R r (x1, y1, z1) (x2, y2, z2)+ addObj3 $ Prim.rect3R r (x1, y1, z1) (x2, y2, z2) square = moduleWithoutSuite "square" $ do - -- examples - example "square(x=[-2,2], y=[-1,5]);"- example "square(size = [3,4], center = true, r = 0.5);"- example "square(4);"+ -- examples + example "square(x=[-2,2], y=[-1,5]);"+ example "square(size = [3,4], center = true, r = 0.5);"+ example "square(4);" - -- arguments- ((x1,x2), (y1,y2)) <-- do- x :: Either ℝ ℝ2 <- argument "x"- `doc` "x or x-interval"- y :: Either ℝ ℝ2 <- argument "y"- `doc` "y or y-interval"- center :: Bool <- argument "center" - `doc` "should center? (non-intervals)" - `defaultTo` False- let toInterval' = toInterval center- return (either (toInterval center) id x,- either (toInterval center) id y)- <|> do- size :: Either ℝ ℝ2 <- argument "size"- `doc` "square size"- center :: Bool <- argument "center" - `doc` "should center?" - `defaultTo` False- let (x,y) = either (\w -> (w,w)) id size- return (toInterval center x, toInterval center y)+ -- arguments+ ((x1,x2), (y1,y2)) <-+ do+ x :: Either ℝ ℝ2 <- argument "x"+ `doc` "x or x-interval"+ y :: Either ℝ ℝ2 <- argument "y"+ `doc` "y or y-interval"+ center :: Bool <- argument "center" + `doc` "should center? (non-intervals)" + `defaultTo` False+ let toInterval' = toInterval center+ return (either (toInterval center) id x,+ either (toInterval center) id y)+ <|> do+ size :: Either ℝ ℝ2 <- argument "size"+ `doc` "square size"+ center :: Bool <- argument "center" + `doc` "should center?" + `defaultTo` False+ let (x,y) = either (\w -> (w,w)) id size+ return (toInterval center x, toInterval center y) - r :: ℝ <- argument "r"- `doc` "radius of rounding" - `defaultTo` 0+ r :: ℝ <- argument "r"+ `doc` "radius of rounding" + `defaultTo` 0 - -- Tests- test "square(2);"- `eulerCharacteristic` 0- test "square(size=[2,3]);"- `eulerCharacteristic` 0+ -- Tests+ test "square(2);"+ `eulerCharacteristic` 0+ test "square(size=[2,3]);"+ `eulerCharacteristic` 0 - addObj2 $ Prim.rectR r (x1, y1) (x2, y2)+ addObj2 $ Prim.rectR r (x1, y1) (x2, y2) 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);"+ example "cylinder(r=10, h=30, center=true);"+ example "cylinder(r1=4, r2=6, h=10);"+ example "cylinder(r=5, h=10, $fn = 6);" - -- arguments- r :: ℝ <- argument "r"- `defaultTo` 1- `doc` "radius of cylinder"- h :: Either ℝ ℝ2 <- argument "h"- `defaultTo` (Left 1)- `doc` "height of cylinder"- r1 :: ℝ <- argument "r1"- `defaultTo` 1- `doc` "bottom radius; overrides r"- r2 :: ℝ <- argument "r2"- `defaultTo` 1- `doc` "top radius; overrides r"- fn :: ℕ <- argument "$fn"- `defaultTo` (-1)- `doc` "number of sides, for making prisms"- center :: Bool <- argument "center"- `defaultTo` False- `doc` "center cylinder with respect to z?"+ -- arguments+ r :: ℝ <- argument "r"+ `defaultTo` 1+ `doc` "radius of cylinder"+ h :: Either ℝ ℝ2 <- argument "h"+ `defaultTo` Left 1+ `doc` "height of cylinder"+ r1 :: ℝ <- argument "r1"+ `defaultTo` 1+ `doc` "bottom radius; overrides r"+ r2 :: ℝ <- argument "r2"+ `defaultTo` 1+ `doc` "top radius; overrides r"+ fn :: ℕ <- argument "$fn"+ `defaultTo` (-1)+ `doc` "number of sides, for making prisms"+ center :: Bool <- argument "center"+ `defaultTo` False+ `doc` "center cylinder with respect to z?" - -- Tests- test "cylinder(r=10, h=30, center=true);"- `eulerCharacteristic` 0- test "cylinder(r=5, h=10, $fn = 6);"- `eulerCharacteristic` 0+ -- Tests+ test "cylinder(r=10, h=30, center=true);"+ `eulerCharacteristic` 0+ test "cylinder(r=5, h=10, $fn = 6);"+ `eulerCharacteristic` 0 - let- (h1, h2) = either (toInterval center) id h- dh = h2 - h1- shift = if h1 == 0 then id else Prim.translate (0,0,h1)+ let+ (h1, h2) = either (toInterval center) id h+ dh = h2 - h1+ shift = if h1 == 0 then id else Prim.translate (0,0,h1) - -- The result is a computation state modifier that adds a 3D object, - -- based on the args.- addObj3 $ if r1 == 1 && r2 == 1- then let- obj2 = if fn < 0 then Prim.circle r else Prim.polygonR 0 $- let sides = fromIntegral fn - in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]]- obj3 = Prim.extrudeR 0 obj2 dh- in shift $ obj3- else shift $ Prim.cylinder2 r1 r2 dh+ -- The result is a computation state modifier that adds a 3D object, + -- based on the args.+ addObj3 $ if r1 == 1 && r2 == 1+ then let+ obj2 = if fn < 0 then Prim.circle r else Prim.polygonR 0 $+ let sides = fromIntegral fn + in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]]+ obj3 = Prim.extrudeR 0 obj2 dh+ in shift obj3+ else shift $ Prim.cylinder2 r1 r2 dh circle = moduleWithoutSuite "circle" $ do- - example "circle(r=10); // circle"- example "circle(r=5, $fn=6); //hexagon"+ + example "circle(r=10); // circle"+ example "circle(r=5, $fn=6); //hexagon" - -- Arguments- r :: ℝ <- argument "r"- `doc` "radius of the circle"- fn :: ℕ <- argument "$fn" - `doc` "if defined, makes a regular polygon with n sides instead of a circle"- `defaultTo` (-1)+ -- Arguments+ r :: ℝ <- argument "r"+ `doc` "radius of the circle"+ fn :: ℕ <- argument "$fn" + `doc` "if defined, makes a regular polygon with n sides instead of a circle"+ `defaultTo` (-1) - test "circle(r=10);"- `eulerCharacteristic` 0+ test "circle(r=10);"+ `eulerCharacteristic` 0 - addObj2 $ if fn < 3- then Prim.circle r- else Prim.polygonR 0 $- let sides = fromIntegral fn - in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]]+ addObj2 $ if fn < 3+ then Prim.circle r+ else Prim.polygonR 0 $+ let sides = fromIntegral fn + in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]] polygon = moduleWithoutSuite "polygon" $ do- - example "polygon ([(0,0), (0,10), (10,0)]);"- - points :: [ℝ2] <- argument "points" - `doc` "vertices of the polygon"- paths :: [ℕ ] <- argument "paths" - `doc` "order to go through vertices; ignored for now"- `defaultTo` []- r :: ℝ <- argument "r"- `doc` "rounding of the polygon corners; ignored for now"- `defaultTo` 0- case paths of- [] -> addObj2 $ Prim.polygonR 0 points- _ -> return $ return []+ + example "polygon ([(0,0), (0,10), (10,0)]);"+ + points :: [ℝ2] <- argument "points" + `doc` "vertices of the polygon"+ paths :: [ℕ ] <- argument "paths" + `doc` "order to go through vertices; ignored for now"+ `defaultTo` []+ r :: ℝ <- argument "r"+ `doc` "rounding of the polygon corners; ignored for now"+ `defaultTo` 0+ case paths of+ [] -> addObj2 $ Prim.polygonR 0 points+ _ -> return $ return [] union = moduleWithSuite "union" $ \children -> do- r :: ℝ <- argument "r"- `defaultTo` 0.0- `doc` "Radius of rounding for the union interface"- return $ return $ if r > 0- then objReduce (Prim.unionR r) (Prim.unionR r) children- else objReduce Prim.union Prim.union children+ r :: ℝ <- argument "r"+ `defaultTo` 0.0+ `doc` "Radius of rounding for the union interface"+ return $ return $ if r > 0+ then objReduce (Prim.unionR r) (Prim.unionR r) children+ else objReduce Prim.union Prim.union children intersect = moduleWithSuite "intersection" $ \children -> do- r :: ℝ <- argument "r"- `defaultTo` 0.0- `doc` "Radius of rounding for the intersection interface"- return $ return $ if r > 0- then objReduce (Prim.intersectR r) (Prim.intersectR r) children- else objReduce Prim.intersect Prim.intersect children+ r :: ℝ <- argument "r"+ `defaultTo` 0.0+ `doc` "Radius of rounding for the intersection interface"+ return $ return $ if r > 0+ then objReduce (Prim.intersectR r) (Prim.intersectR r) children+ else objReduce Prim.intersect Prim.intersect children difference = moduleWithSuite "difference" $ \children -> do- r :: ℝ <- argument "r"- `defaultTo` 0.0- `doc` "Radius of rounding for the difference interface"- return $ return $ if r > 0- then objReduce (Prim.differenceR r) (Prim.differenceR r) children- else objReduce Prim.difference Prim.difference children+ r :: ℝ <- argument "r"+ `defaultTo` 0.0+ `doc` "Radius of rounding for the difference interface"+ return $ return $ if r > 0+ then objReduce (Prim.differenceR r) (Prim.differenceR r) children+ else objReduce Prim.difference Prim.difference children translate = moduleWithSuite "translate" $ \children -> do - example "translate ([2,3]) circle (4);"- example "translate ([5,6,7]) sphere(5);"+ example "translate ([2,3]) circle (4);"+ example "translate ([5,6,7]) sphere(5);" - (x,y,z) <- - do- x :: ℝ <- argument "x"- `doc` "x amount to translate";- y :: ℝ <- argument "y"- `doc` "y amount to translate";- z :: ℝ <- argument "z"- `doc` "z amount to translate"- `defaultTo` 0;- return (x,y,z);- <|> do- v :: Either ℝ (Either ℝ2 ℝ3) <- argument "v"- `doc` "vector to translate by"- return $ case v of- 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+ (x,y,z) <- + do+ x :: ℝ <- argument "x"+ `doc` "x amount to translate";+ y :: ℝ <- argument "y"+ `doc` "y amount to translate";+ z :: ℝ <- argument "z"+ `doc` "z amount to translate"+ `defaultTo` 0;+ return (x,y,z);+ <|> do+ v :: Either ℝ (Either ℝ2 ℝ3) <- argument "v"+ `doc` "vector to translate by"+ return $ case v of+ 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 deg2rad x = x / 180.0 * pi -- This is mostly insane rotate = moduleWithSuite "rotate" $ \children -> do- a <- argument "a"- `doc` "value to rotate by; angle or list of angles"- v <- argument "v" `defaultTo` (0, 0, 1)- `doc` "Vector to rotate around if a is a single angle"+ a <- argument "a"+ `doc` "value to rotate by; angle or list of angles"+ v <- argument "v" `defaultTo` (0, 0, 1)+ `doc` "Vector to rotate around if a is a single angle" - -- caseOType matches depending on whether size can be coerced into- -- the right object. See Graphics.Implicit.ExtOpenScad.Util- -- Entries must be joined with the operator <||>- -- Final entry must be fall through.- return $ return $ caseOType a $- ( \θ ->+ -- caseOType matches depending on whether size can be coerced into+ -- the right object. See Graphics.Implicit.ExtOpenScad.Util+ -- Entries must be joined with the operator <||>+ -- Final entry must be fall through.+ return $ return $ caseOType a $+ ( \θ -> objMap (Prim.rotate $ deg2rad θ) (Prim.rotate3V (deg2rad θ) v) children- ) <||> ( \(yz,zx,xy) ->- objMap (Prim.rotate $ deg2rad xy ) (Prim.rotate3 (deg2rad yz, deg2rad zx, deg2rad xy) ) children- ) <||> ( \(yz,zx) ->- objMap (id ) (Prim.rotate3 (deg2rad yz, deg2rad zx, 0)) children- ) <||> ( \_ -> [] )+ ) <||> ( \(yz,zx,xy) ->+ objMap (Prim.rotate $ deg2rad xy ) (Prim.rotate3 (deg2rad yz, deg2rad zx, deg2rad xy) ) children+ ) <||> ( \(yz,zx) ->+ objMap id (Prim.rotate3 (deg2rad yz, deg2rad zx, 0)) children+ ) <||> const [] scale = moduleWithSuite "scale" $ \children -> do - example "scale(2) square(5);"- example "scale([2,3]) square(5);"- example "scale([2,3,4]) cube(5);"+ example "scale(2) square(5);"+ example "scale([2,3]) square(5);"+ example "scale([2,3,4]) cube(5);" - v :: Either ℝ (Either ℝ2 ℝ3) <- argument "v"- `doc` "vector or scalar to scale by"- - let- scaleObjs strech2 strech3 = - objMap (Prim.scale strech2) (Prim.scale strech3) children- - return $ return $ case v of- Left x -> scaleObjs (x,1) (x,1,1)- Right (Left (x,y)) -> scaleObjs (x,y) (x,y,1)- Right (Right (x,y,z)) -> scaleObjs (x,y) (x,y,z)+ v :: Either ℝ (Either ℝ2 ℝ3) <- argument "v"+ `doc` "vector or scalar to scale by"+ + let+ scaleObjs strech2 strech3 = + objMap (Prim.scale strech2) (Prim.scale strech3) children+ + return $ return $ case v of+ Left x -> scaleObjs (x,1) (x,1,1)+ Right (Left (x,y)) -> scaleObjs (x,y) (x,y,1)+ Right (Right (x,y,z)) -> scaleObjs (x,y) (x,y,z) extrude = moduleWithSuite "linear_extrude" $ \children -> do- example "linear_extrude(10) square(5);"+ example "linear_extrude(10) square(5);" - height :: Either ℝ (ℝ -> ℝ -> ℝ) <- argument "height" `defaultTo` (Left 1)- `doc` "height to extrude to..."- center :: Bool <- argument "center" `defaultTo` False- `doc` "center? (the z component)"- twist :: Maybe (Either ℝ (ℝ -> ℝ)) <- argument "twist" `defaultTo` Nothing- `doc` "twist as we extrude, either a total amount to twist or a function..."- scale :: Maybe (Either ℝ (ℝ -> ℝ)) <- argument "scale" `defaultTo` Nothing- `doc` "scale according to this funciton as we extrud..."- translate :: Maybe (Either ℝ2 (ℝ -> ℝ2)) <- argument "translate" `defaultTo` Nothing- `doc` "translate according to this funciton as we extrude..."- r :: ℝ <- argument "r" `defaultTo` 0- `doc` "round the top?"- - let- degRotate = (\θ (x,y) -> (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ))) . (*(2*pi/360))+ height :: Either ℝ (ℝ -> ℝ -> ℝ) <- argument "height" `defaultTo` Left 1+ `doc` "height to extrude to..."+ center :: Bool <- argument "center" `defaultTo` False+ `doc` "center? (the z component)"+ twist :: Maybe (Either ℝ (ℝ -> ℝ)) <- argument "twist" `defaultTo` Nothing+ `doc` "twist as we extrude, either a total amount to twist or a function..."+ scale :: Maybe (Either ℝ (ℝ -> ℝ)) <- argument "scale" `defaultTo` Nothing+ `doc` "scale according to this funciton as we extrud..."+ translate :: Maybe (Either ℝ2 (ℝ -> ℝ2)) <- argument "translate" `defaultTo` Nothing+ `doc` "translate according to this funciton as we extrude..."+ r :: ℝ <- argument "r" `defaultTo` 0+ `doc` "round the top?"+ + let+ degRotate = (\θ (x,y) -> (x * cos θ + y * sin θ, y * cos θ - x * sin θ)) . (*(2*pi/360)) - heightn = case height of- Left h -> h- Right f -> f 0 0+ heightn = case height of+ Left h -> h+ Right f -> f 0 0 - height' = case height of- Right f -> Right $ uncurry f- Left a -> Left a+ height' = case height of+ Right f -> Right $ uncurry f+ Left a -> Left a - shiftAsNeeded =- if center- then Prim.translate (0,0,-heightn/2.0)- else id- - 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 scale- translate' = fmap funcify translate- - return $ return $ obj2UpMap (- \obj -> case height of- Left constHeight | isNothing twist && isNothing scale && isNothing translate ->- shiftAsNeeded $ Prim.extrudeR r obj constHeight- _ -> - shiftAsNeeded $ Prim.extrudeRM r twist' scale' translate' obj height'- ) children+ shiftAsNeeded =+ if center+ then Prim.translate (0,0,-heightn/2.0)+ else id+ + 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 scale+ translate' = fmap funcify translate+ + return $ return $ obj2UpMap (+ \obj -> case height of+ Left constHeight | isNothing twist && isNothing scale && isNothing translate ->+ shiftAsNeeded $ Prim.extrudeR r obj constHeight+ _ -> + shiftAsNeeded $ Prim.extrudeRM r twist' scale' translate' obj height'+ ) children rotateExtrude = moduleWithSuite "rotate_extrude" $ \children -> do- example "rotate_extrude() translate(20) circle(10);"+ example "rotate_extrude() translate(20) circle(10);" - totalRot :: ℝ <- argument "a" `defaultTo` 360- `doc` "angle to sweep"- r :: ℝ <- argument "r" `defaultTo` 0- translate :: Either ℝ2 (ℝ -> ℝ2) <- argument "translate" `defaultTo` Left (0,0)+ totalRot :: ℝ <- argument "a" `defaultTo` 360+ `doc` "angle to sweep"+ r :: ℝ <- argument "r" `defaultTo` 0+ translate :: Either ℝ2 (ℝ -> ℝ2) <- argument "translate" `defaultTo` Left (0,0)+ rotate :: Either ℝ (ℝ -> ℝ ) <- argument "rotate" `defaultTo` Left 0 - let- n = fromIntegral $ round $ totalRot / 360- cap = (360*n /= totalRot) - || (Either.either ( /= (0,0)) (\f -> f 0 /= f totalRot) ) translate- capM = if cap then Just r else Nothing- - return $ return $ obj2UpMap (Prim.rotateExtrude totalRot capM translate) children+ let+ is360m n = 360 * fromIntegral (round $ n / 360) /= n+ n = fromIntegral $ round $ totalRot / 360+ cap = is360m totalRot + || Either.either ( /= (0,0)) (\f -> f 0 /= f totalRot) translate+ || Either.either is360m (\f -> is360m (f 0 - f totalRot)) rotate+ capM = if cap then Just r else Nothing+ + return $ return $ obj2UpMap (Prim.rotateExtrude totalRot capM translate rotate) children {-rotateExtrudeStatement = moduleWithSuite "rotate_extrude" $ \suite -> do- h <- realArgument "h"- center <- boolArgumentWithDefault "center" False- twist <- realArgumentWithDefault 0.0- r <- realArgumentWithDefault "r" 0.0- getAndModUpObj2s suite (\obj -> Prim.extrudeRMod r (\θ (x,y) -> (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ)) ) obj h) + h <- realArgument "h"+ center <- boolArgumentWithDefault "center" False+ twist <- realArgumentWithDefault 0.0+ r <- realArgumentWithDefault "r" 0.0+ getAndModUpObj2s suite (\obj -> Prim.extrudeRMod r (\θ (x,y) -> (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ)) ) obj h) -} shell = moduleWithSuite "shell" $ \children-> do- w :: ℝ <- argument "w"- `doc` "width of the shell..."- - return $ return $ objMap (Prim.shell w) (Prim.shell w) children+ w :: ℝ <- argument "w"+ `doc` "width of the shell..."+ + return $ return $ objMap (Prim.shell w) (Prim.shell w) children -- Not a perenant solution! Breaks if can't pack. pack = moduleWithSuite "pack" $ \children -> do - example "pack ([45,45], sep=2) { circle(10); circle(10); circle(10); circle(10); }"+ example "pack ([45,45], sep=2) { circle(10); circle(10); circle(10); circle(10); }" - -- arguments- size :: ℝ2 <- argument "size"- `doc` "size of 2D box to pack objects within"- sep :: ℝ <- argument "sep"- `doc` "mandetory space between objects"+ -- arguments+ size :: ℝ2 <- argument "size"+ `doc` "size of 2D box to pack objects within"+ sep :: ℝ <- argument "sep"+ `doc` "mandetory space between objects" - -- The actual work...- return $- let (obj2s, obj3s, others) = divideObjs children- in if not $ null obj3s- then case Prim.pack3 size sep obj3s of- Just solution -> return $ OObj3 solution : (map OObj2 obj2s ++ others)- Nothing -> do - putStrLn "Can't pack given objects in given box with present algorithm"- return children- else case Prim.pack2 size sep obj2s of- Just solution -> return $ OObj2 solution : others- Nothing -> do - putStrLn "Can't pack given objects in given box with present algorithm"- return children+ -- The actual work...+ return $+ let (obj2s, obj3s, others) = divideObjs children+ in if not $ null obj3s+ then case Prim.pack3 size sep obj3s of+ Just solution -> return $ OObj3 solution : (map OObj2 obj2s ++ others)+ Nothing -> do + putStrLn "Can't pack given objects in given box with present algorithm"+ return children+ else case Prim.pack2 size sep obj2s of+ Just solution -> return $ OObj2 solution : others+ Nothing -> do + putStrLn "Can't pack given objects in given box with present algorithm"+ return children unit = moduleWithSuite "unit" $ \children -> do - example "unit(\"inch\") {..}"+ example "unit(\"inch\") {..}" - -- arguments- unit :: String <- argument "unit"- `doc` "the unit you wish to work in"+ -- arguments+ unit :: String <- argument "unit"+ `doc` "the unit you wish to work in" - let - mmRatio "inch" = Just 25.4- mmRatio "in" = mmRatio "inch"- mmRatio "foot" = Just 304.8- mmRatio "ft" = mmRatio "foot"- mmRatio "yard" = Just 914.4- mmRatio "yd" = mmRatio "yard"- mmRatio "mm" = Just 1- mmRatio "cm" = Just 10- mmRatio "dm" = Just 100- mmRatio "m" = Just 1000- mmRatio "km" = Just 1000000- mmRatio "µm" = Just 0.001- mmRatio "um" = mmRatio "µm"- mmRatio "nm" = Just 0.0000001- mmRatio _ = Nothing+ let + mmRatio "inch" = Just 25.4+ mmRatio "in" = mmRatio "inch"+ mmRatio "foot" = Just 304.8+ mmRatio "ft" = mmRatio "foot"+ mmRatio "yard" = Just 914.4+ mmRatio "yd" = mmRatio "yard"+ mmRatio "mm" = Just 1+ mmRatio "cm" = Just 10+ mmRatio "dm" = Just 100+ mmRatio "m" = Just 1000+ mmRatio "km" = Just 1000000+ mmRatio "µm" = Just 0.001+ mmRatio "um" = mmRatio "µm"+ mmRatio "nm" = Just 0.0000001+ mmRatio _ = Nothing - -- The actual work...- return $ case mmRatio unit of- Nothing -> do- putStrLn $ "unrecognized unit " ++ unit- return children- Just r -> - return $ objMap (Prim.scale (r,r)) (Prim.scale (r,r,r)) children+ -- The actual work...+ return $ case mmRatio unit of+ Nothing -> do+ putStrLn $ "unrecognized unit " ++ unit+ return children+ Just r -> + return $ objMap (Prim.scale (r,r)) (Prim.scale (r,r,r)) children ---------------@@ -458,7 +461,7 @@ (<|>) = Monad.mplus moduleWithSuite name modArgMapper = (name, modArgMapper)-moduleWithoutSuite name modArgMapper = (name, \suite -> modArgMapper)+moduleWithoutSuite name modArgMapper = (name, const modArgMapper) addObj3 :: SymbolicObj3 -> ArgParser (IO [OVal]) addObj3 x = return $ return [OObj3 x]@@ -467,23 +470,23 @@ addObj2 x = return $ return [OObj2 x] objMap obj2mod obj3mod (x:xs) = case x of- OObj2 obj2 -> OObj2 (obj2mod obj2) : objMap obj2mod obj3mod xs- OObj3 obj3 -> OObj3 (obj3mod obj3) : objMap obj2mod obj3mod xs- a -> a : objMap obj2mod obj3mod xs+ OObj2 obj2 -> OObj2 (obj2mod obj2) : objMap obj2mod obj3mod xs+ OObj3 obj3 -> OObj3 (obj3mod obj3) : objMap obj2mod obj3mod xs+ a -> a : objMap obj2mod obj3mod xs objMap _ _ [] = [] objReduce obj2reduce obj3reduce l = case divideObjs l of- ( [], [], others) -> others- ( [], obj3s, others) -> OObj3 (obj3reduce obj3s) : others- (obj2s, [], others) -> OObj2 (obj2reduce obj2s) : others- (obj2s, obj3s, others) -> OObj2 (obj2reduce obj2s) : OObj3 (obj3reduce obj3s) : others+ ( [], [], others) -> others+ ( [], obj3s, others) -> OObj3 (obj3reduce obj3s) : others+ (obj2s, [], others) -> OObj2 (obj2reduce obj2s) : others+ (obj2s, obj3s, others) -> OObj2 (obj2reduce obj2s) : OObj3 (obj3reduce obj3s) : others obj2UpMap obj2upmod (x:xs) = case x of- OObj2 obj2 -> OObj3 (obj2upmod obj2) : obj2UpMap obj2upmod xs- a -> a : obj2UpMap obj2upmod xs+ OObj2 obj2 -> OObj3 (obj2upmod obj2) : obj2UpMap obj2upmod xs+ a -> a : obj2UpMap obj2upmod xs obj2UpMap _ [] = [] toInterval center h = - if center- then (-h/2, h/2)- else (0, h)+ if center+ then (-h/2, h/2)+ else (0, h)
Graphics/Implicit/ExtOpenScad/Util/ArgParser.hs view
@@ -8,32 +8,44 @@ import qualified Control.Exception as Ex import qualified Data.Map as Map import qualified Data.Maybe as Maybe+import Control.Applicative import Control.Monad +instance Alternative ArgParser where+ (<|>) = mplus+ empty = mzero++instance Functor ArgParser where+ fmap = liftM++instance Applicative ArgParser where+ pure = return+ (<*>) = ap+ instance Monad ArgParser where - -- return is easy: if we want an ArgParser that just gives us a, that is - -- ArgParserTerminator a- return a = APTerminator a+ -- return is easy: if we want an ArgParser that just gives us a, that is + -- ArgParserTerminator a+ return a = APTerminator a - -- Now things get more interesting. We need to describe how (>>=) works.- -- Let's get the hard ones out of the way first.- -- ArgParser actually - (AP str fallback doc f) >>= g = AP str fallback doc (\a -> (f a) >>= g)- (APFailIf b errmsg child) >>= g = APFailIf b errmsg (child >>= g)- -- These next to is easy, they just pass the work along to their child- (APExample str child) >>= g = APExample str (child >>= g)- (APTest str tests child) >>= g = APTest str tests (child >>= g)- -- And an ArgParserTerminator happily gives away the value it contains- (APTerminator a) >>= g = g a- (APBranch bs) >>= g = APBranch $ map (>>= g) bs+ -- Now things get more interesting. We need to describe how (>>=) works.+ -- Let's get the hard ones out of the way first.+ -- ArgParser actually + (AP str fallback doc f) >>= g = AP str fallback doc (\a -> (f a) >>= g)+ (APFailIf b errmsg child) >>= g = APFailIf b errmsg (child >>= g)+ -- These next to is easy, they just pass the work along to their child+ (APExample str child) >>= g = APExample str (child >>= g)+ (APTest str tests child) >>= g = APTest str tests (child >>= g)+ -- And an ArgParserTerminator happily gives away the value it contains+ (APTerminator a) >>= g = g a+ (APBranch bs) >>= g = APBranch $ map (>>= g) bs instance MonadPlus ArgParser where- mzero = APFailIf True "" undefined- mplus (APBranch as) (APBranch bs) = APBranch ( as ++ bs )- mplus (APBranch as) b = APBranch ( as ++ [b] )- mplus a (APBranch bs) = APBranch ( [a] ++ bs )- mplus a b = APBranch [ a , b ]+ mzero = APFailIf True "" undefined+ mplus (APBranch as) (APBranch bs) = APBranch ( as ++ bs )+ mplus (APBranch as) b = APBranch ( as ++ [b] )+ mplus a (APBranch bs) = APBranch ( [a] ++ bs )+ mplus a b = APBranch [ a , b ] -- * ArgParser building functions @@ -41,21 +53,21 @@ argument :: forall desiredType. (OTypeMirror desiredType) => String -> ArgParser desiredType argument name = - AP name Nothing "" $ \oObjVal -> do- let- val = fromOObj oObjVal :: Maybe desiredType- errmsg = case oObjVal of- OError errs -> "error in computing value for arugment " ++ name- ++ ": " ++ concat errs- _ -> "arg " ++ show oObjVal ++ " not compatible with " ++ name- -- Using /= Nothing would require Eq desiredType- APFailIf (Maybe.isNothing val) errmsg $ APTerminator $ (\(Just a) -> a) val+ AP name Nothing "" $ \oObjVal -> do+ let+ val = fromOObj oObjVal :: Maybe desiredType+ errmsg = case oObjVal of+ OError errs -> "error in computing value for arugment " ++ name+ ++ ": " ++ concat errs+ _ -> "arg " ++ show oObjVal ++ " not compatible with " ++ name+ -- Using /= Nothing would require Eq desiredType+ APFailIf (Maybe.isNothing val) errmsg $ APTerminator $ (\(Just a) -> a) val doc (AP name defMaybeVal _ next) newDoc = AP name defMaybeVal newDoc next defaultTo :: forall a. (OTypeMirror a) => ArgParser a -> a -> ArgParser a defaultTo (AP name oldDefMaybeVal doc next) newDefVal = - AP name (Just $ toOObj newDefVal) doc next+ AP name (Just $ toOObj newDefVal) doc next -- ** example @@ -69,55 +81,55 @@ eulerCharacteristic :: ArgParser a -> Int -> ArgParser a eulerCharacteristic (APTest str tests child) χ =- APTest str ((EulerCharacteristic χ) : tests) child+ APTest str ((EulerCharacteristic χ) : tests) child -- * Tools for handeling ArgParsers -- | Apply arguments to an ArgParser argMap :: - [(Maybe String, OVal)] -- ^ arguments- -> ArgParser a -- ^ ArgParser to apply them to- -> (Maybe a, [String]) -- ^ (result, error messages)+ [(Maybe String, OVal)] -- ^ arguments+ -> ArgParser a -- ^ ArgParser to apply them to+ -> (Maybe a, [String]) -- ^ (result, error messages) argMap args = argMap2 unnamedArgs (Map.fromList namedArgs) where- unnamedArgs = map snd $ filter (Maybe.isNothing . fst) args- namedArgs = map (\(a,b) -> (Maybe.fromJust a, b)) $ filter (Maybe.isJust . fst) args+ unnamedArgs = map snd $ filter (Maybe.isNothing . fst) args+ namedArgs = map (\(a,b) -> (Maybe.fromJust a, b)) $ filter (Maybe.isJust . fst) args argMap2 :: [OVal] -> Map.Map String OVal -> ArgParser a -> (Maybe a, [String]) argMap2 uArgs nArgs (APBranch branches) =- foldl1 merge solutions where- solutions = map (argMap2 uArgs nArgs) branches- merge a@(Just _, []) _ = a- merge _ b@(Just _, []) = b- merge a@(Just _, _) _ = a- merge (Nothing, _) a = a+ foldl1 merge solutions where+ solutions = map (argMap2 uArgs nArgs) branches+ merge a@(Just _, []) _ = a+ merge _ b@(Just _, []) = b+ merge a@(Just _, _) _ = a+ merge (Nothing, _) a = a argMap2 unnamedArgs namedArgs (AP name fallback _ f) = - case Map.lookup name namedArgs of- Just a -> argMap2 - unnamedArgs - (Map.delete name namedArgs) - (f a)- Nothing -> case unnamedArgs of- x:xs -> argMap2 xs namedArgs (f x)- [] -> case fallback of- Just b -> argMap2 [] namedArgs (f b)- Nothing -> (Nothing, ["No value and no default for argument " ++ name])+ case Map.lookup name namedArgs of+ Just a -> argMap2 + unnamedArgs + (Map.delete name namedArgs) + (f a)+ Nothing -> case unnamedArgs of+ x:xs -> argMap2 xs namedArgs (f x)+ [] -> case fallback of+ Just b -> argMap2 [] namedArgs (f b)+ Nothing -> (Nothing, ["No value and no default for argument " ++ name]) argMap2 a b (APTerminator val) = - (Just val,- if not (null a && Map.null b)- then ["unused arguments"]- else []- )+ (Just val,+ if not (null a && Map.null b)+ then ["unused arguments"]+ else []+ ) argMap2 a b (APFailIf test err child) = - if test - then (Nothing, [err])- else argMap2 a b child+ if test + then (Nothing, [err])+ else argMap2 a b child argMap2 a b (APExample str child) = argMap2 a b child @@ -143,18 +155,18 @@ -- | Extract Documentation from an ArgParser getArgParserDocs :: - (ArgParser a) -- ^ ArgParser- -> IO [DocPart] -- ^ Docs (sadly IO wrapped)+ (ArgParser a) -- ^ ArgParser+ -> IO [DocPart] -- ^ Docs (sadly IO wrapped) getArgParserDocs (ArgParser name fallback doc fnext) = - do- otherDocs <- Ex.catch (getArgParserDocs $ fnext undefined) (\(e :: Ex.SomeException) -> return [])- return $ (ArgumentDoc name (fmap show fallback) doc):otherDocs+ do+ otherDocs <- Ex.catch (getArgParserDocs $ fnext undefined) (\(e :: Ex.SomeException) -> return [])+ return $ (ArgumentDoc name (fmap show fallback) doc):otherDocs getArgParserDocs (ArgParserExample str child) =- do- childResults <- getArgParserDocs child- return $ (ExampleDoc str) : childResults+ do+ childResults <- getArgParserDocs child+ return $ (ExampleDoc str) : childResults -- We try to look at as little as possible, to avoid the risk of triggering an error. -- Yay laziness!
Graphics/Implicit/ExtOpenScad/Util/OVal.hs view
@@ -1,5 +1,4 @@--{-# LANGUAGE ViewPatterns, RankNTypes, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, OverlappingInstances #-}+{-# LANGUAGE ViewPatterns, RankNTypes, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-} module Graphics.Implicit.ExtOpenScad.Util.OVal where @@ -10,79 +9,79 @@ -- | We'd like to be able to turn OVals into a given Haskell type class OTypeMirror a where- fromOObj :: OVal -> Maybe a- toOObj :: a -> OVal+ fromOObj :: OVal -> Maybe a+ toOObj :: a -> OVal instance OTypeMirror OVal where- fromOObj a = Just a- toOObj a = a+ fromOObj a = Just a+ toOObj a = a instance OTypeMirror ℝ where- fromOObj (ONum n) = Just n- fromOObj _ = Nothing- toOObj n = ONum n+ fromOObj (ONum n) = Just n+ fromOObj _ = Nothing+ toOObj n = ONum n instance OTypeMirror ℕ where- fromOObj (ONum n) = if n == fromIntegral (floor n) then Just (floor n) else Nothing- fromOObj _ = Nothing- toOObj n = ONum $ fromIntegral n+ fromOObj (ONum n) = if n == fromIntegral (floor n) then Just (floor n) else Nothing+ fromOObj _ = Nothing+ toOObj n = ONum $ fromIntegral n instance OTypeMirror Bool where- fromOObj (OBool b) = Just b- fromOObj _ = Nothing- toOObj b = OBool b+ fromOObj (OBool b) = Just b+ fromOObj _ = Nothing+ toOObj b = OBool b -instance OTypeMirror String where- fromOObj (OString str) = Just str- fromOObj _ = Nothing- toOObj str = OString str+instance {-# Overlapping #-} OTypeMirror String where+ fromOObj (OString str) = Just str+ fromOObj _ = Nothing+ toOObj str = OString str instance forall a. (OTypeMirror a) => OTypeMirror (Maybe a) where- fromOObj a = Just $ fromOObj a- toOObj (Just a) = toOObj a- toOObj Nothing = OUndefined+ fromOObj a = Just $ fromOObj a+ toOObj (Just a) = toOObj a+ toOObj Nothing = OUndefined -instance forall a. (OTypeMirror a) => OTypeMirror [a] where- fromOObj (OList list) = Monad.sequence . map fromOObj $ list- fromOObj _ = Nothing- toOObj list = OList $ map toOObj list+instance {-# Overlappable #-} forall a. (OTypeMirror a) => OTypeMirror [a] where+ fromOObj (OList list) = Monad.sequence . map fromOObj $ list+ fromOObj _ = Nothing+ toOObj list = OList $ map toOObj list instance forall a b. (OTypeMirror a, OTypeMirror b) => OTypeMirror (a,b) where- fromOObj (OList ((fromOObj -> Just a):(fromOObj -> Just b):[])) = Just (a,b)- fromOObj _ = Nothing- toOObj (a,b) = OList [toOObj a, toOObj b]+ fromOObj (OList ((fromOObj -> Just a):(fromOObj -> Just b):[])) = Just (a,b)+ fromOObj _ = Nothing+ toOObj (a,b) = OList [toOObj a, toOObj b] instance forall a b c. (OTypeMirror a, OTypeMirror b, OTypeMirror c) => OTypeMirror (a,b,c) where- fromOObj (OList ((fromOObj -> Just a):(fromOObj -> Just b):(fromOObj -> Just c):[])) = - Just (a,b,c)- fromOObj _ = Nothing- toOObj (a,b,c) = OList [toOObj a, toOObj b, toOObj c]+ fromOObj (OList ((fromOObj -> Just a):(fromOObj -> Just b):(fromOObj -> Just c):[])) = + Just (a,b,c)+ fromOObj _ = Nothing+ toOObj (a,b,c) = OList [toOObj a, toOObj b, toOObj c] instance forall a b. (OTypeMirror a, OTypeMirror b) => OTypeMirror (a -> b) where- fromOObj (OFunc f) = Just $ \input ->- let- oInput = toOObj input- oOutput = f oInput- output = fromOObj oOutput :: Maybe b- in case output of- Just out -> out- Nothing -> error $ "coercing OVal to a -> b isn't always safe; use a -> Maybe b"- ++ " (trace: " ++ show oInput ++ " -> " ++ show oOutput ++ " )"- fromOObj _ = Nothing- toOObj f = OFunc $ \oObj -> - case fromOObj oObj :: Maybe a of- Nothing -> OError ["bad input type"]- Just obj -> toOObj $ f obj+ fromOObj (OFunc f) = Just $ \input ->+ let+ oInput = toOObj input+ oOutput = f oInput+ output = fromOObj oOutput :: Maybe b+ in case output of+ Just out -> out+ Nothing -> error $ "coercing OVal to a -> b isn't always safe; use a -> Maybe b"+ ++ " (trace: " ++ show oInput ++ " -> " ++ show oOutput ++ " )"+ fromOObj _ = Nothing+ toOObj f = OFunc $ \oObj -> + case fromOObj oObj :: Maybe a of+ Nothing -> OError ["bad input type"]+ Just obj -> toOObj $ f obj instance forall a b. (OTypeMirror a, OTypeMirror b) => OTypeMirror (Either a b) where- fromOObj (fromOObj -> Just (x :: a)) = Just $ Left x- fromOObj (fromOObj -> Just (x :: b)) = Just $ Right x- fromOObj _ = Nothing+ fromOObj (fromOObj -> Just (x :: a)) = Just $ Left x+ fromOObj (fromOObj -> Just (x :: b)) = Just $ Right x+ fromOObj _ = Nothing - toOObj (Right x) = toOObj x- toOObj (Left x) = toOObj x+ toOObj (Right x) = toOObj x+ toOObj (Left x) = toOObj x oTypeStr (OUndefined) = "Undefined" oTypeStr (OBool _ ) = "Bool"@@ -106,32 +105,32 @@ infixr 2 <||> (<||>) :: forall desiredType out. (OTypeMirror desiredType)- => (desiredType -> out) - -> (OVal -> out)- -> (OVal -> out)+ => (desiredType -> out) + -> (OVal -> out)+ -> (OVal -> out) (<||>) f g = \input ->- let- coerceAttempt = fromOObj input :: Maybe desiredType- in - if isJust coerceAttempt -- ≅ (/= Nothing) but no Eq req- then f $ (\(Just a) -> a) coerceAttempt- else g input+ let+ coerceAttempt = fromOObj input :: Maybe desiredType+ in + if isJust coerceAttempt -- ≅ (/= Nothing) but no Eq req+ then f $ (\(Just a) -> a) coerceAttempt+ else g input divideObjs children = - (map fromOObj2 . filter isOObj2 $ children,- map fromOObj3 . filter isOObj3 $ children,- filter (not . isOObj) $ children)- where- isOObj2 (OObj2 _) = True- isOObj2 _ = False- isOObj3 (OObj3 _) = True- isOObj3 _ = False- isOObj (OObj2 _) = True- isOObj (OObj3 _) = True- isOObj _ = False- fromOObj2 (OObj2 x) = x- fromOObj3 (OObj3 x) = x+ (map fromOObj2 . filter isOObj2 $ children,+ map fromOObj3 . filter isOObj3 $ children,+ filter (not . isOObj) $ children)+ where+ isOObj2 (OObj2 _) = True+ isOObj2 _ = False+ isOObj3 (OObj3 _) = True+ isOObj3 _ = False+ isOObj (OObj2 _) = True+ isOObj (OObj3 _) = True+ isOObj _ = False+ fromOObj2 (OObj2 x) = x+ fromOObj3 (OObj3 x) = x
Graphics/Implicit/ExtOpenScad/Util/StateC.hs view
@@ -24,44 +24,44 @@ lookupVar :: String -> StateC (Maybe OVal) lookupVar name = do- varlookup <- getVarLookup- return $ Map.lookup name varlookup+ varlookup <- getVarLookup+ return $ Map.lookup name varlookup pushVals :: [OVal] -> StateC () pushVals vals = modify (\(a,b,c,d,e) -> (a, vals ++ b,c,d,e)) getVals :: StateC [OVal] getVals = do- (a,b,c,d,e) <- get- return b+ (a,b,c,d,e) <- get+ return b putVals :: [OVal] -> StateC () putVals vals = do- (a,b,c,d,e) <- get- put (a,vals,c,d,e)+ (a,b,c,d,e) <- get+ put (a,vals,c,d,e) withPathShiftedBy :: FilePath -> StateC a -> StateC a withPathShiftedBy pathShift s = do- (a,b,path,d,e) <- get- put (a,b, path </> pathShift, d, e)- x <- s- (a',b',_,d',e') <- get- put (a', b', path, d', e')- return x+ (a,b,path,d,e) <- get+ put (a,b, path </> pathShift, d, e)+ x <- s+ (a',b',_,d',e') <- get+ put (a', b', path, d', e')+ return x getPath :: StateC FilePath getPath = do- (a,b,c,d,e) <- get- return c+ (a,b,c,d,e) <- get+ return c getRelPath :: FilePath -> StateC FilePath getRelPath relPath = do- path <- getPath- return $ path </> relPath+ path <- getPath+ return $ path </> relPath errorC lineN err = liftIO $ putStrLn $ "At " ++ show lineN ++ ": " ++ err mapMaybeM f (Just a) = do- b <- f a- return (Just b)+ b <- f a+ return (Just b) mapMaybeM f Nothing = return Nothing
Graphics/Implicit/MathUtil.hs view
@@ -11,25 +11,25 @@ -- | The distance a point p is from a line segment (a,b) distFromLineSeg :: ℝ2 -> (ℝ2,ℝ2) -> ℝ distFromLineSeg p (a,b) = magnitude (closest .-. p)- where- ab = b ^-^ a- ap = p ^-^ a- d = normalized ab ⋅ ap- closest- | d < 0 = a- | d > magnitude ab = b- | otherwise = a ^+^ d *^ normalized ab+ where+ ab = b ^-^ a+ ap = p ^-^ a+ d = normalized ab ⋅ ap+ closest+ | d < 0 = a+ | d > magnitude ab = b+ | otherwise = a ^+^ d *^ normalized ab - + box3sWithin :: ℝ -> (ℝ3, ℝ3) -> (ℝ3,ℝ3) -> Bool box3sWithin r ((ax1, ay1, az1),(ax2, ay2, az2)) ((bx1, by1, bz1),(bx2, by2, bz2)) =- let- near (a1, a2) (b1, b2) = not $ (a2 + r < b1) || (b2 + r < a1)- in- (ax1,ax2) `near` (bx1, bx2)- && (ay1,ay2) `near` (by1, by2)- && (az1,az2) `near` (bz1, bz2)+ let+ near (a1, a2) (b1, b2) = not $ (a2 + r < b1) || (b2 + r < a1)+ in+ (ax1,ax2) `near` (bx1, bx2)+ && (ay1,ay2) `near` (by1, by2)+ && (az1,az2) `near` (bz1, bz2) -- | Rounded Maximum@@ -37,23 +37,23 @@ -- has a square-like corner. We replace it with a -- quarter of a circle rmax :: - ℝ -- ^ radius- -> ℝ -- ^ first number to round maximum- -> ℝ -- ^ second number to round maximum- -> ℝ -- ^ resulting number+ ℝ -- ^ radius+ -> ℝ -- ^ first number to round maximum+ -> ℝ -- ^ second number to round maximum+ -> ℝ -- ^ resulting number rmax r x y = if abs (x-y) < r - then y - r*sin(pi/4-asin((x-y)/r/sqrt 2)) + r- else max x y+ then y - r*sin(pi/4-asin((x-y)/r/sqrt 2)) + r+ else max x y -- | Rounded minimum rmin :: - ℝ -- ^ radius- -> ℝ -- ^ first number to round minimum- -> ℝ -- ^ second number to round minimum- -> ℝ -- ^ resulting number+ ℝ -- ^ radius+ -> ℝ -- ^ first number to round minimum+ -> ℝ -- ^ second number to round minimum+ -> ℝ -- ^ resulting number rmin r x y = if abs (x-y) < r - then y + r*sin(pi/4+asin((x-y)/r/sqrt 2)) - r- else min x y+ then y + r*sin(pi/4+asin((x-y)/r/sqrt 2)) - r+ else min x y -- | Like rmax, but on a list instead of two. -- Just as maximum is.@@ -61,66 +61,66 @@ -- and rmax those. rmaximum ::- ℝ -- ^ radius- -> [ℝ] -- ^ numbers to take round maximum- -> ℝ -- ^ resulting number+ ℝ -- ^ radius+ -> [ℝ] -- ^ numbers to take round maximum+ -> ℝ -- ^ resulting number rmaximum _ (a:[]) = a rmaximum r (a:b:[]) = rmax r a b rmaximum r l = - let- tops = reverse $ sort l- in- rmax r (tops !! 0) (tops !! 1)+ let+ tops = reverse $ sort l+ in+ rmax r (tops !! 0) (tops !! 1) -- | Like rmin but on a list. rminimum ::- ℝ -- ^ radius- -> [ℝ] -- ^ numbers to take round minimum- -> ℝ -- ^ resulting number+ ℝ -- ^ radius+ -> [ℝ] -- ^ numbers to take round minimum+ -> ℝ -- ^ resulting number rminimum r (a:[]) = a rminimum r (a:b:[]) = rmin r a b rminimum r l = - let- tops = sort l- in- rmin r (tops !! 0) (tops !! 1)+ let+ tops = sort l+ in+ rmin r (tops !! 0) (tops !! 1) pack :: - Box2 -- ^ The box to pack within- -> ℝ -- ^ The space seperation between items- -> [(Box2, a)] -- ^ Objects with their boxes- -> ([(ℝ2, a)], [(Box2, a)] ) -- ^ Packed objects with their positions, objects that could be packed+ Box2 -- ^ The box to pack within+ -> ℝ -- ^ The space seperation between items+ -> [(Box2, a)] -- ^ Objects with their boxes+ -> ([(ℝ2, a)], [(Box2, a)] ) -- ^ Packed objects with their positions, objects that could be packed pack (dx, dy) sep objs = packSome sortedObjs (dx, dy)- where- compareBoxesByY ((_, ay1), (_, ay2)) ((_, by1), (_, by2)) = - compare (abs $ by2-by1) (abs $ ay2 - ay1)+ where+ compareBoxesByY ((_, ay1), (_, ay2)) ((_, by1), (_, by2)) = + compare (abs $ by2-by1) (abs $ ay2 - ay1) - sortedObjs = sortBy - (\(boxa, _) (boxb, _) -> compareBoxesByY boxa boxb ) - objs+ sortedObjs = sortBy + (\(boxa, _) (boxb, _) -> compareBoxesByY boxa boxb ) + objs - tmap1 f (a,b) = (f a, b)- tmap2 f (a,b) = (a, f b)+ tmap1 f (a,b) = (f a, b)+ tmap2 f (a,b) = (a, f b) - --packSome :: [(Box2,a)] -> Box2 -> ([(ℝ2,a)], [(Box2,a)])- packSome (presObj@(((x1,y1),(x2,y2)),obj):otherBoxedObjs) box@((bx1, by1), (bx2, by2)) = - if abs (x2 - x1) <= abs (bx2-bx1) && abs (y2 - y1) <= abs (by2-by1)- then - let- row = tmap1 (((bx1-x1,by1-y1), obj):) $- packSome otherBoxedObjs ((bx1+x2-x1+sep, by1), (bx2, by1 + y2-y1))- rowAndUp = - if abs (by2-by1) - abs (y2-y1) > sep- then tmap1 ((fst row) ++ ) $- packSome (snd row) ((bx1, by1 + y2-y1+sep), (bx2, by2))- else row- in- rowAndUp- else- tmap2 (presObj:) $ packSome otherBoxedObjs box- packSome [] _ = ([], [])+ --packSome :: [(Box2,a)] -> Box2 -> ([(ℝ2,a)], [(Box2,a)])+ packSome (presObj@(((x1,y1),(x2,y2)),obj):otherBoxedObjs) box@((bx1, by1), (bx2, by2)) = + if abs (x2 - x1) <= abs (bx2-bx1) && abs (y2 - y1) <= abs (by2-by1)+ then + let+ row = tmap1 (((bx1-x1,by1-y1), obj):) $+ packSome otherBoxedObjs ((bx1+x2-x1+sep, by1), (bx2, by1 + y2-y1))+ rowAndUp = + if abs (by2-by1) - abs (y2-y1) > sep+ then tmap1 ((fst row) ++ ) $+ packSome (snd row) ((bx1, by1 + y2-y1+sep), (bx2, by2))+ else row+ in+ rowAndUp+ else+ tmap2 (presObj:) $ packSome otherBoxedObjs box+ packSome [] _ = ([], [])
Graphics/Implicit/ObjectUtil/GetBox2.hs view
@@ -15,23 +15,23 @@ pointsBox :: [ℝ2] -> Box2 pointsBox points =- let- (xs, ys) = unzip points- in- ((minimum xs, minimum ys), (maximum xs, maximum ys))+ let+ (xs, ys) = unzip points+ in+ ((minimum xs, minimum ys), (maximum xs, maximum ys)) unionBoxes :: [Box2] -> Box2 unionBoxes boxes =- let- (leftbot, topright) = unzip $ filter (not.isEmpty) boxes- (lefts, bots) = unzip leftbot- (rights, tops) = unzip topright- in- ((minimum lefts, minimum bots), (maximum rights, maximum tops))+ let+ (leftbot, topright) = unzip $ filter (not.isEmpty) boxes+ (lefts, bots) = unzip leftbot+ (rights, tops) = unzip topright+ in+ ((minimum lefts, minimum bots), (maximum rights, maximum tops)) outsetBox :: ℝ -> Box2 -> Box2 outsetBox r (a,b) =- (a ^-^ (r,r), b ^+^ (r,r))+ (a ^-^ (r,r), b ^+^ (r,r)) getBox2 :: SymbolicObj2 -> Box2 @@ -41,66 +41,66 @@ getBox2 (Circle r ) = ((-r, -r), (r,r)) getBox2 (PolygonR r points) = ((minimum xs, minimum ys), (maximum xs, maximum ys)) - where (xs, ys) = unzip points+ where (xs, ys) = unzip points -- (Rounded) CSG getBox2 (Complement2 symbObj) = - ((-infty, -infty), (infty, infty)) where infty = 1/0+ ((-infty, -infty), (infty, infty)) where infty = 1/0 getBox2 (UnionR2 r symbObjs) =- outsetBox r $ unionBoxes (map getBox2 symbObjs)+ outsetBox r $ unionBoxes (map getBox2 symbObjs) getBox2 (DifferenceR2 r symbObjs) =- let - firstBox:_ = map getBox2 symbObjs- in- firstBox+ let + firstBox:_ = map getBox2 symbObjs+ in+ firstBox getBox2 (IntersectR2 r symbObjs) = - let - boxes = map getBox2 symbObjs- (leftbot, topright) = unzip boxes- (lefts, bots) = unzip leftbot- (rights, tops) = unzip topright- left = maximum lefts- bot = maximum bots- right = minimum rights- top = minimum tops- in- ((left-r,bot-r),(right+r,top+r))+ let + boxes = map getBox2 symbObjs+ (leftbot, topright) = unzip boxes+ (lefts, bots) = unzip leftbot+ (rights, tops) = unzip topright+ left = maximum lefts+ bot = maximum bots+ right = minimum rights+ top = minimum tops+ in+ ((left-r,bot-r),(right+r,top+r)) -- Simple transforms getBox2 (Translate2 v symbObj) =- let- (a,b) = getBox2 symbObj- in- if isEmpty (a,b)- then ((0,0),(0,0))- else (a^+^v, b^+^v)+ let+ (a,b) = getBox2 symbObj+ in+ if isEmpty (a,b)+ then ((0,0),(0,0))+ else (a^+^v, b^+^v) getBox2 (Scale2 s symbObj) =- let- (a,b) = getBox2 symbObj- in- (s ⋯* a, s ⋯* b)+ let+ (a,b) = getBox2 symbObj+ in+ (s ⋯* a, s ⋯* b) getBox2 (Rotate2 θ symbObj) = - let- ((x1,y1), (x2,y2)) = getBox2 symbObj- rotate (x,y) = (cos(θ)*x - sin(θ)*y, sin(θ)*x + cos(θ)*y)- in- pointsBox [ rotate (x1, y1)- , rotate (x1, y2)- , rotate (x2, y1)- , rotate (x2, y2)- ]+ let+ ((x1,y1), (x2,y2)) = getBox2 symbObj+ rotate (x,y) = (cos(θ)*x - sin(θ)*y, sin(θ)*x + cos(θ)*y)+ in+ pointsBox [ rotate (x1, y1)+ , rotate (x1, y2)+ , rotate (x2, y1)+ , rotate (x2, y2)+ ] -- Boundary mods getBox2 (Shell2 w symbObj) = - outsetBox (w/2) $ getBox2 symbObj+ outsetBox (w/2) $ getBox2 symbObj getBox2 (Outset2 d symbObj) =- outsetBox d $ getBox2 symbObj+ outsetBox d $ getBox2 symbObj -- Misc getBox2 (EmbedBoxedObj2 (obj,box)) = box@@ -116,11 +116,11 @@ getDist2 p (Circle r) = magnitude p + r -getDist2 (x,y) symbObj =- let- ((x1,y1), (x2,y2)) = getBox2 symbObj- in- sqrt ((max (abs (x1 - x)) (abs (x2 - x)))^2 + (max (abs (y1 - y)) (abs (y2 - y)))^2)- getDist2 p (PolygonR r points) = - r + maximum [magnitude (p ^-^ p') | p' <- points]+ r + maximum [magnitude (p ^-^ p') | p' <- points]++getDist2 (x,y) symbObj =+ let+ ((x1,y1), (x2,y2)) = getBox2 symbObj+ in+ sqrt ((max (abs (x1 - x)) (abs (x2 - x)))^2 + (max (abs (y1 - y)) (abs (y2 - y)))^2)
Graphics/Implicit/ObjectUtil/GetBox3.hs view
@@ -20,7 +20,7 @@ outsetBox :: ℝ -> Box3 -> Box3 outsetBox r (a,b) =- (a ^-^ (r,r,r), b ^+^ (r,r,r))+ (a ^-^ (r,r,r), b ^+^ (r,r,r)) getBox3 :: SymbolicObj3 -> Box3 @@ -33,145 +33,150 @@ -- (Rounded) CSG getBox3 (Complement3 symbObj) = - ((-infty, -infty, -infty), (infty, infty, infty)) where infty = 1/0+ ((-infty, -infty, -infty), (infty, infty, infty)) where infty = 1/0 getBox3 (UnionR3 r symbObjs) = ((left-r,bot-r,inward-r), (right+r,top+r,out+r))- where - boxes = map getBox3 symbObjs- isEmpty = ( == ((0,0,0),(0,0,0)) )- (leftbot, topright) = unzip $ filter (not.isEmpty) boxes- (lefts, bots, ins) = unzip3 leftbot- (rights, tops, outs) = unzip3 topright- left = minimum lefts- bot = minimum bots- inward = minimum ins- right = maximum rights- top = maximum tops- out = maximum outs+ where + boxes = map getBox3 symbObjs+ isEmpty = ( == ((0,0,0),(0,0,0)) )+ (leftbot, topright) = unzip $ filter (not.isEmpty) boxes+ (lefts, bots, ins) = unzip3 leftbot+ (rights, tops, outs) = unzip3 topright+ left = minimum lefts+ bot = minimum bots+ inward = minimum ins+ right = maximum rights+ top = maximum tops+ out = maximum outs getBox3 (IntersectR3 r symbObjs) = - let - boxes = map getBox3 symbObjs- (leftbot, topright) = unzip boxes- (lefts, bots, ins) = unzip3 leftbot- (rights, tops, outs) = unzip3 topright- left = maximum lefts- bot = maximum bots- inward = maximum ins- right = minimum rights- top = minimum tops- out = minimum outs- in- if top > bot - && right > left - && out > inward- then ((left,bot,inward),(right,top,out))- else ((0,0,0),(0,0,0))+ let + boxes = map getBox3 symbObjs+ (leftbot, topright) = unzip boxes+ (lefts, bots, ins) = unzip3 leftbot+ (rights, tops, outs) = unzip3 topright+ left = maximum lefts+ bot = maximum bots+ inward = maximum ins+ right = minimum rights+ top = minimum tops+ out = minimum outs+ in+ if top > bot + && right > left + && out > inward+ then ((left,bot,inward),(right,top,out))+ else ((0,0,0),(0,0,0)) getBox3 (DifferenceR3 r symbObjs) = firstBox- where- firstBox:_ = map getBox3 symbObjs+ where+ firstBox:_ = map getBox3 symbObjs -- Simple transforms getBox3 (Translate3 v symbObj) =- let- (a,b) = getBox3 symbObj- in- (a^+^v, b^+^v)+ let+ (a,b) = getBox3 symbObj+ in+ (a^+^v, b^+^v) getBox3 (Scale3 s symbObj) =- let- (a,b) = getBox3 symbObj- in- (s ⋯* a, s ⋯* b)+ let+ (a,b) = getBox3 symbObj+ in+ (s ⋯* a, s ⋯* b) getBox3 (Rotate3 _ symbObj) = ( (-d, -d, -d), (d, d, d) )- where- ((x1,y1, z1), (x2,y2, z2)) = getBox3 symbObj- d = (sqrt 3 *) $ maximum $ map abs [x1, x2, y1, y2, z1, z2]+ where+ ((x1,y1, z1), (x2,y2, z2)) = getBox3 symbObj+ d = (sqrt 3 *) $ maximum $ map abs [x1, x2, y1, y2, z1, z2] getBox3 (Rotate3V _ v symbObj) = getBox3 (Rotate3 v symbObj) -- Boundary mods getBox3 (Shell3 w symbObj) =- outsetBox (w/2) $ getBox3 symbObj+ outsetBox (w/2) $ getBox3 symbObj getBox3 (Outset3 d symbObj) =- outsetBox d $ getBox3 symbObj+ outsetBox d $ getBox3 symbObj -- Misc getBox3 (EmbedBoxedObj3 (obj,box)) = box -- 2D Based getBox3 (ExtrudeR r symbObj h) = ((x1,y1,0),(x2,y2,h))- where- ((x1,y1),(x2,y2)) = getBox2 symbObj+ where+ ((x1,y1),(x2,y2)) = getBox2 symbObj getBox3 (ExtrudeOnEdgeOf symbObj1 symbObj2) =- let- ((ax1,ay1),(ax2,ay2)) = getBox2 symbObj1- ((bx1,by1),(bx2,by2)) = getBox2 symbObj2- in- ((bx1+ax1, by1+ax1, ay2), (bx2+ax2, by2+ax2, ay2))+ let+ ((ax1,ay1),(ax2,ay2)) = getBox2 symbObj1+ ((bx1,by1),(bx2,by2)) = getBox2 symbObj2+ in+ ((bx1+ax1, by1+ax1, ay2), (bx2+ax2, by2+ax2, ay2)) getBox3 (ExtrudeRM r twist scale translate symbObj eitherh) = - let- range = [0, 0.1 .. 1.0]+ let+ range = [0, 0.1 .. 1.0] - ((x1,y1),(x2,y2)) = getBox2 symbObj- (dx,dy) = (x2 - x1, y2 - y1)- (xrange, yrange) = (map (\s -> x1+s*dx) $ range, map (\s -> y1+s*dy) $ range )+ ((x1,y1),(x2,y2)) = getBox2 symbObj+ (dx,dy) = (x2 - x1, y2 - y1)+ (xrange, yrange) = (map (\s -> x1+s*dx) $ range, map (\s -> y1+s*dy) $ range ) - h = case eitherh of- Left h -> h- Right hf -> hmax + 0.2*(hmax-hmin)- where- hs = [hf (x,y) | x <- xrange, y <- yrange]- (hmin, hmax) = (minimum hs, maximum hs)- - hrange = map (h*) $ range+ h = case eitherh of+ Left h -> h+ Right hf -> hmax + 0.2*(hmax-hmin)+ where+ hs = [hf (x,y) | x <- xrange, y <- yrange]+ (hmin, hmax) = (minimum hs, maximum hs)+ + hrange = map (h*) $ range - sval = case scale of- Nothing -> 1- Just scale' -> maximum $ map (abs . scale') hrange- - (twistXmin, twistYmin, twistXmax, twistYmax) = case twist of- Nothing -> (smin x1, smin y1, smax x2, smax y2)- where- smin y = min y (sval * y)- smax y = max y (sval * y)- Just _ -> (-d, -d, d, d)- where d = sval * getDist2 (0,0) symbObj- - translate' = fromMaybe (const (0,0)) translate- (tvalsx, tvalsy) = unzip . map (translate' . (h*)) $ hrange- (tminx, tminy) = (minimum tvalsx, minimum tvalsy)- (tmaxx, tmaxy) = (maximum tvalsx, maximum tvalsy)- in- ((twistXmin + tminx, twistYmin + tminy, 0),(twistXmax + tmaxx, twistYmax + tmaxy, h))+ sval = case scale of+ Nothing -> 1+ Just scale' -> maximum $ map (abs . scale') hrange+ + (twistXmin, twistYmin, twistXmax, twistYmax) = case twist of+ Nothing -> (smin x1, smin y1, smax x2, smax y2)+ where+ smin y = min y (sval * y)+ smax y = max y (sval * y)+ Just _ -> (-d, -d, d, d)+ where d = sval * getDist2 (0,0) symbObj+ + translate' = fromMaybe (const (0,0)) translate+ (tvalsx, tvalsy) = unzip . map (translate' . (h*)) $ hrange+ (tminx, tminy) = (minimum tvalsx, minimum tvalsy)+ (tmaxx, tmaxy) = (maximum tvalsx, maximum tvalsy)+ in+ ((twistXmin + tminx, twistYmin + tminy, 0),(twistXmax + tmaxx, twistYmax + tmaxy, h)) -getBox3 (RotateExtrude _ _ (Left (xshift,yshift)) symbObj) = - let- ((x1,y1),(x2,y2)) = getBox2 symbObj- r = max x2 (x2 + xshift)- in- ((-r, -r, min y1 (y1 + yshift)),(r, r, max y2 (y2 + yshift)))+getBox3 (RotateExtrude _ _ (Left (xshift,yshift)) rotate symbObj) = + let+ ((x1,y1),(x2,y2)) = getBox2 symbObj+ g = maximum $ map abs [x1, x2, y1, y2]+ r = max x2 (x2 + xshift)+ in+ ((-r, -r, min y1 (y1 + yshift)),(r, r, max y2 (y2 + yshift))) -getBox3 (RotateExtrude rot _ (Right f) symbObj) = - let- ((x1,y1),(x2,y2)) = getBox2 symbObj- (xshifts, yshifts) = unzip [f θ | θ <- [0 , rot / 10 .. rot] ]- xmax = maximum xshifts- ymax = maximum yshifts- ymin = minimum yshifts- xmax' = if xmax > 0 then xmax * 1.1 else if xmax < - x1 then 0 else xmax- ymax' = ymax + 0.1 * (ymax - ymin)- ymin' = ymin - 0.1 * (ymax - ymin)- r = x2 + xmax'- in- ((-r, -r, y1 + ymin'),(r, r, y2 + ymax'))+getBox3 (RotateExtrude rot _ (Right f) rotate symbObj) = + let+ ((x1,y1),(x2,y2)) = getBox2 symbObj+ (xshifts, yshifts) = unzip [f θ | θ <- [0 , rot / 10 .. rot] ]+ xmax = maximum xshifts+ ymax = maximum yshifts+ ymin = minimum yshifts+ xmax' = if xmax > 0 then xmax * 1.1 else if xmax < - x1 then 0 else xmax+ ymax' = ymax + 0.1 * (ymax - ymin)+ ymin' = ymin - 0.1 * (ymax - ymin)+ (r, z1, z2) = if either (==0) (const False) rotate+ then let+ s = maximum $ map abs [x2, y1, y2]+ in (s + xmax', s + ymin', y2 + ymax')+ else (x2 + xmax', y1 + ymin', y2 + ymax')+ in+ ((-r, -r, y1 + ymin'),(r, r, y2 + ymax'))
Graphics/Implicit/ObjectUtil/GetImplicit2.hs view
@@ -14,91 +14,91 @@ -- Primitives getImplicit2 (RectR r (x1,y1) (x2,y2)) = \(x,y) -> MathUtil.rmaximum r- [abs (x-dx/2-x1) - dx/2, abs (y-dy/2-y1) - dy/2]- where (dx, dy) = (x2-x1, y2-y1)+ [abs (x-dx/2-x1) - dx/2, abs (y-dy/2-y1) - dy/2]+ where (dx, dy) = (x2-x1, y2-y1) getImplicit2 (Circle r ) = - \(x,y) -> sqrt (x**2 + y**2) - r+ \(x,y) -> sqrt (x**2 + y**2) - r getImplicit2 (PolygonR r points) = - \p -> let- pair :: Int -> (ℝ2,ℝ2)- pair n = (points !! n, points !! (mod (n + 1) (length points) ) )- pairs = [ pair n | n <- [0 .. (length points) - 1] ]- relativePairs = map (\(a,b) -> (a ^-^ p, b ^-^ p) ) pairs- crossing_points =- [x2 ^-^ y2*(x2-x1)/(y2-y1) | ((x1,y1), (x2,y2)) <-relativePairs,- ( (y2 <= 0) && (y1 >= 0) ) || ( (y2 >= 0) && (y1 <= 0) ) ]- seemsInRight = odd $ length $ filter (>0) $ nub crossing_points- seemsInLeft = odd $ length $ filter (<0) $ nub crossing_points- isIn = seemsInRight && seemsInLeft- dists = map (MathUtil.distFromLineSeg p) pairs :: [ℝ]- in- minimum dists * if isIn then -1 else 1+ \p -> let+ pair :: Int -> (ℝ2,ℝ2)+ pair n = (points !! n, points !! (mod (n + 1) (length points) ) )+ pairs = [ pair n | n <- [0 .. (length points) - 1] ]+ relativePairs = map (\(a,b) -> (a ^-^ p, b ^-^ p) ) pairs+ crossing_points =+ [x2 ^-^ y2*(x2-x1)/(y2-y1) | ((x1,y1), (x2,y2)) <-relativePairs,+ ( (y2 <= 0) && (y1 >= 0) ) || ( (y2 >= 0) && (y1 <= 0) ) ]+ seemsInRight = odd $ length $ filter (>0) $ nub crossing_points+ seemsInLeft = odd $ length $ filter (<0) $ nub crossing_points+ isIn = seemsInRight && seemsInLeft+ dists = map (MathUtil.distFromLineSeg p) pairs :: [ℝ]+ in+ minimum dists * if isIn then -1 else 1 -- (Rounded) CSG getImplicit2 (Complement2 symbObj) = - let- obj = getImplicit2 symbObj- in- \p -> - obj p+ let+ obj = getImplicit2 symbObj+ in+ \p -> - obj p getImplicit2 (UnionR2 r symbObjs) =- let - objs = map getImplicit2 symbObjs- in- if r == 0- then \p -> minimum $ map ($p) objs - else \p -> MathUtil.rminimum r $ map ($p) objs+ let + objs = map getImplicit2 symbObjs+ in+ if r == 0+ then \p -> minimum $ map ($p) objs + else \p -> MathUtil.rminimum r $ map ($p) objs getImplicit2 (DifferenceR2 r symbObjs) =- let - obj:objs = map getImplicit2 symbObjs- complement obj = \p -> - obj p- in- if r == 0- then \p -> maximum $ map ($p) $ obj:(map complement objs) - else \p -> MathUtil.rmaximum r $ map ($p) $ obj:(map complement objs) + let + obj:objs = map getImplicit2 symbObjs+ complement obj = \p -> - obj p+ in+ if r == 0+ then \p -> maximum $ map ($p) $ obj:(map complement objs) + else \p -> MathUtil.rmaximum r $ map ($p) $ obj:(map complement objs) getImplicit2 (IntersectR2 r symbObjs) = - let - objs = map getImplicit2 symbObjs- in- if r == 0- then \p -> maximum $ map ($p) objs - else \p -> MathUtil.rmaximum r $ map ($p) objs+ let + objs = map getImplicit2 symbObjs+ in+ if r == 0+ then \p -> maximum $ map ($p) objs + else \p -> MathUtil.rmaximum r $ map ($p) objs -- Simple transforms getImplicit2 (Translate2 v symbObj) =- let- obj = getImplicit2 symbObj- in- \p -> obj (p ^-^ v)+ let+ obj = getImplicit2 symbObj+ in+ \p -> obj (p ^-^ v) getImplicit2 (Scale2 s@(sx,sy) symbObj) =- let- obj = getImplicit2 symbObj- in- \p -> (max sx sy) * obj (p ⋯/ s)+ let+ obj = getImplicit2 symbObj+ in+ \p -> (max sx sy) * obj (p ⋯/ s) getImplicit2 (Rotate2 θ symbObj) = - let- obj = getImplicit2 symbObj- in- \(x,y) -> obj ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x)+ let+ obj = getImplicit2 symbObj+ in+ \(x,y) -> obj ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x) -- Boundary mods getImplicit2 (Shell2 w symbObj) = - let- obj = getImplicit2 symbObj- in- \p -> abs (obj p) - w/2+ let+ obj = getImplicit2 symbObj+ in+ \p -> abs (obj p) - w/2 getImplicit2 (Outset2 d symbObj) =- let- obj = getImplicit2 symbObj- in- \p -> obj p - d+ let+ obj = getImplicit2 symbObj+ in+ \p -> obj p - d -- Misc getImplicit2 (EmbedBoxedObj2 (obj,box)) = obj
Graphics/Implicit/ObjectUtil/GetImplicit3.hs view
@@ -20,175 +20,190 @@ -- Primitives getImplicit3 (Rect3R r (x1,y1,z1) (x2,y2,z2)) = \(x,y,z) -> MathUtil.rmaximum r- [abs (x-dx/2-x1) - dx/2, abs (y-dy/2-y1) - dy/2, abs (z-dz/2-z1) - dz/2]- where (dx, dy, dz) = (x2-x1, y2-y1, z2-z1)+ [abs (x-dx/2-x1) - dx/2, abs (y-dy/2-y1) - dy/2, abs (z-dz/2-z1) - dz/2]+ where (dx, dy, dz) = (x2-x1, y2-y1, z2-z1) getImplicit3 (Sphere r ) = - \(x,y,z) -> sqrt (x**2 + y**2 + z**2) - r+ \(x,y,z) -> sqrt (x**2 + y**2 + z**2) - r getImplicit3 (Cylinder h r1 r2) = \(x,y,z) ->- let- d = sqrt(x^2+y^2) - ((r2-r1)/h*z+r1)- θ = atan2 (r2-r1) h- in- max (d * cos θ) (abs(z-h/(2::ℝ)) - h/(2::ℝ))+ let+ d = sqrt(x^2+y^2) - ((r2-r1)/h*z+r1)+ θ = atan2 (r2-r1) h+ in+ max (d * cos θ) (abs(z-h/(2::ℝ)) - h/(2::ℝ)) -- (Rounded) CSG getImplicit3 (Complement3 symbObj) = - let- obj = getImplicit3 symbObj- in- \p -> - obj p+ let+ obj = getImplicit3 symbObj+ in+ \p -> - obj p getImplicit3 (UnionR3 r symbObjs) =- let - objs = map getImplicit3 symbObjs- in- if r == 0- then \p -> minimum $ map ($p) objs - else \p -> MathUtil.rminimum r $ map ($p) objs+ let + objs = map getImplicit3 symbObjs+ in+ if r == 0+ then \p -> minimum $ map ($p) objs + else \p -> MathUtil.rminimum r $ map ($p) objs getImplicit3 (IntersectR3 r symbObjs) = - let - objs = map getImplicit3 symbObjs- in- if r == 0- then \p -> maximum $ map ($p) objs - else \p -> MathUtil.rmaximum r $ map ($p) objs+ let + objs = map getImplicit3 symbObjs+ in+ if r == 0+ then \p -> maximum $ map ($p) objs + else \p -> MathUtil.rmaximum r $ map ($p) objs getImplicit3 (DifferenceR3 r symbObjs) =- let - obj:objs = map getImplicit3 symbObjs- complement obj = \p -> - obj p- in- if r == 0- then \p -> maximum $ map ($p) $ obj:(map complement objs) - else \p -> MathUtil.rmaximum r $ map ($p) $ obj:(map complement objs) + let + obj:objs = map getImplicit3 symbObjs+ complement obj = \p -> - obj p+ in+ if r == 0+ then \p -> maximum $ map ($p) $ obj:(map complement objs) + else \p -> MathUtil.rmaximum r $ map ($p) $ obj:(map complement objs) -- Simple transforms getImplicit3 (Translate3 v symbObj) =- let- obj = getImplicit3 symbObj- in- \p -> obj (p ^-^ v)+ let+ obj = getImplicit3 symbObj+ in+ \p -> obj (p ^-^ v) getImplicit3 (Scale3 s@(sx,sy,sz) symbObj) =- let- obj = getImplicit3 symbObj- k = (sx*sy*sz)**(1/3)- in- \p -> k * obj (p ⋯/ s)+ let+ obj = getImplicit3 symbObj+ k = (sx*sy*sz)**(1/3)+ in+ \p -> k * obj (p ⋯/ s) getImplicit3 (Rotate3 (yz, zx, xy) symbObj) = - let- obj = getImplicit3 symbObj- rotateYZ :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)- rotateYZ θ obj = \(x,y,z) -> obj ( x, cos(θ)*y + sin(θ)*z, cos(θ)*z - sin(θ)*y)- rotateZX :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)- rotateZX θ obj = \(x,y,z) -> obj ( cos(θ)*x - sin(θ)*z, y, cos(θ)*z + sin(θ)*x)- rotateXY :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)- rotateXY θ obj = \(x,y,z) -> obj ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x, z)- in- rotateYZ yz $ rotateZX zx $ rotateXY xy $ obj+ let+ obj = getImplicit3 symbObj+ rotateYZ :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)+ rotateYZ θ obj = \(x,y,z) -> obj ( x, cos(θ)*y + sin(θ)*z, cos(θ)*z - sin(θ)*y)+ rotateZX :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)+ rotateZX θ obj = \(x,y,z) -> obj ( cos(θ)*x - sin(θ)*z, y, cos(θ)*z + sin(θ)*x)+ rotateXY :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)+ rotateXY θ obj = \(x,y,z) -> obj ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x, z)+ in+ rotateYZ yz $ rotateZX zx $ rotateXY xy $ obj getImplicit3 (Rotate3V θ axis symbObj) =- let- axis' = normalized axis- obj = getImplicit3 symbObj- in- \v -> obj $ - v ^* cos(θ) - ^-^ (axis' `cross3` v) ^* sin(θ) - ^+^ (axis' ^* (axis' <.> (v ^* (1 - cos(θ)))))+ let+ axis' = normalized axis+ obj = getImplicit3 symbObj+ in+ \v -> obj $ + v ^* cos(θ) + ^-^ (axis' `cross3` v) ^* sin(θ) + ^+^ (axis' ^* (axis' <.> (v ^* (1 - cos(θ))))) -- Boundary mods getImplicit3 (Shell3 w symbObj) = - let- obj = getImplicit3 symbObj- in- \p -> abs (obj p) - w/2+ let+ obj = getImplicit3 symbObj+ in+ \p -> abs (obj p) - w/2 getImplicit3 (Outset3 d symbObj) =- let- obj = getImplicit3 symbObj- in- \p -> obj p - d+ let+ obj = getImplicit3 symbObj+ in+ \p -> obj p - d -- Misc getImplicit3 (EmbedBoxedObj3 (obj,box)) = obj -- 2D Based getImplicit3 (ExtrudeR r symbObj h) = - let- obj = getImplicit2 symbObj- in- \(x,y,z) -> MathUtil.rmax r (obj (x,y)) (abs (z - h/2) - h/2)+ let+ obj = getImplicit2 symbObj+ in+ \(x,y,z) -> MathUtil.rmax r (obj (x,y)) (abs (z - h/2) - h/2) getImplicit3 (ExtrudeRM r twist scale translate symbObj height) = - let- obj = getImplicit2 symbObj- twist' = Maybe.fromMaybe (const 0) twist- scale' = Maybe.fromMaybe (const 1) scale- translate' = Maybe.fromMaybe (const (0,0)) translate- height' (x,y) = case height of- Left n -> n- Right f -> f (x,y)- scaleVec :: ℝ -> ℝ2 -> ℝ2- scaleVec s = \(x,y) -> (x/s, y/s)- rotateVec :: ℝ -> ℝ2 -> ℝ2- rotateVec θ (x,y) = (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ)) - k = (pi :: ℝ)/(180:: ℝ)- in- \(x,y,z) -> let h = height' (x,y) in- MathUtil.rmax r - (obj . rotateVec (-k*twist' z) . scaleVec (scale' z) . (\a -> a ^-^ translate' z) $ (x,y))- (abs (z - h/2) - h/2)+ let+ obj = getImplicit2 symbObj+ twist' = Maybe.fromMaybe (const 0) twist+ scale' = Maybe.fromMaybe (const 1) scale+ translate' = Maybe.fromMaybe (const (0,0)) translate+ height' (x,y) = case height of+ Left n -> n+ Right f -> f (x,y)+ scaleVec :: ℝ -> ℝ2 -> ℝ2+ scaleVec s = \(x,y) -> (x/s, y/s)+ rotateVec :: ℝ -> ℝ2 -> ℝ2+ rotateVec θ (x,y) = (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ)) + k = (pi :: ℝ)/(180:: ℝ)+ in+ \(x,y,z) -> let h = height' (x,y) in+ MathUtil.rmax r + (obj . rotateVec (-k*twist' z) . scaleVec (scale' z) . (\a -> a ^-^ translate' z) $ (x,y))+ (abs (z - h/2) - h/2) getImplicit3 (ExtrudeOnEdgeOf symbObj1 symbObj2) =- let- obj1 = getImplicit2 symbObj1- obj2 = getImplicit2 symbObj2- in- \(x,y,z) -> obj1 (obj2 (x,y), z)+ let+ obj1 = getImplicit2 symbObj1+ obj2 = getImplicit2 symbObj2+ in+ \(x,y,z) -> obj1 (obj2 (x,y), z) -getImplicit3 (RotateExtrude totalRotation round translate symbObj) = - let- tau = 2 * pi- k = tau / 360- totalRotation' = totalRotation*k- obj = getImplicit2 symbObj- capped = Maybe.isJust round- round' = Maybe.fromMaybe 0 round- translate' :: ℝ -> ℝ2- translate' = Either.either - (\(a,b) -> \θ -> (a*θ/totalRotation', b*θ/totalRotation')) - (. (/k))- translate- in- \(x,y,z) -> minimum $ do- - let - r = sqrt (x^2 + y^2)- θ = atan2 y x- ns :: [Int]- ns =- if capped- then -- we will cap a different way, but want leeway to keep the function cont- [-1 .. (ceiling (totalRotation' / tau) :: Int) + (1 :: Int)]- else- [0 .. floor $ (totalRotation' - θ) /tau]- n <- ns- let- θvirt = fromIntegral n * tau + θ- (rshift, zshift) = translate' θvirt - rz_pos = (r - rshift, z - zshift)- return $- if capped- then MathUtil.rmax round' - (abs (θvirt - (totalRotation' / 2)) - (totalRotation' / 2))- (obj rz_pos)- else obj rz_pos+getImplicit3 (RotateExtrude totalRotation round translate rotate symbObj) = + let+ tau = 2 * pi+ k = tau / 360+ totalRotation' = totalRotation*k+ obj = getImplicit2 symbObj+ capped = Maybe.isJust round+ round' = Maybe.fromMaybe 0 round+ translate' :: ℝ -> ℝ2+ translate' = Either.either + (\(a,b) -> \θ -> (a*θ/totalRotation', b*θ/totalRotation')) + (. (/k))+ translate+ rotate' :: ℝ -> ℝ+ rotate' = Either.either + (\t -> \θ -> t*θ/totalRotation' ) + (. (/k))+ rotate+ twists = case rotate of+ Left 0 -> True+ _ -> False+ in+ \(x,y,z) -> minimum $ do+ + let + r = sqrt (x^2 + y^2)+ θ = atan2 y x+ ns :: [Int]+ ns =+ if capped+ then -- we will cap a different way, but want leeway to keep the function cont+ [-1 .. (ceiling (totalRotation' / tau) :: Int) + (1 :: Int)]+ else+ [0 .. floor $ (totalRotation' - θ) /tau]+ n <- ns+ let+ θvirt = fromIntegral n * tau + θ+ (rshift, zshift) = translate' θvirt + twist = rotate' θvirt+ rz_pos = if twists + then let + (c,s) = (cos(twist*k), sin(twist*k))+ (r',z') = (r-rshift, z-zshift)+ in+ (c*r' - s*z', c*z' + s*r')+ else (r - rshift, z - zshift)+ return $+ if capped+ then MathUtil.rmax round' + (abs (θvirt - (totalRotation' / 2)) - (totalRotation' / 2))+ (obj rz_pos)+ else obj rz_pos
Graphics/Implicit/Primitives.hs view
@@ -6,195 +6,214 @@ module Graphics.Implicit.Primitives where import Graphics.Implicit.Definitions-import Data.List (sortBy) import Graphics.Implicit.MathUtil (pack) import Graphics.Implicit.ObjectUtil (getBox2, getBox3, getImplicit2, getImplicit3) -- $ 3D Primitives sphere ::- ℝ -- ^ Radius of the sphere- -> SymbolicObj3 -- ^ Resulting sphere--sphere r = Sphere r+ ℝ -- ^ Radius of the sphere+ -> SymbolicObj3 -- ^ Resulting sphere+sphere = Sphere rect3R ::- ℝ -- ^ Rounding of corners- -> ℝ3 -- ^ Bottom.. corner- -> ℝ3 -- ^ Top right... corner- -> SymbolicObj3 -- ^ Resuting cube - (0,0,0) is bottom left...+ ℝ -- ^ Rounding of corners+ -> ℝ3 -- ^ Bottom.. corner+ -> ℝ3 -- ^ Top right... corner+ -> SymbolicObj3 -- ^ Resuting cube - (0,0,0) is bottom left... rect3R = Rect3R cylinder2 ::- ℝ -- ^ Radius of the cylinder - -> ℝ -- ^ Second radius of the cylinder- -> ℝ -- ^ Height of the cylinder- -> SymbolicObj3 -- ^ Resulting cylinder+ ℝ -- ^ Radius of the cylinder + -> ℝ -- ^ Second radius of the cylinder+ -> ℝ -- ^ Height of the cylinder+ -> SymbolicObj3 -- ^ Resulting cylinder cylinder2 r1 r2 h = Cylinder h r1 r2 +cylinder :: ℝ -> ℝ -> SymbolicObj3 cylinder r = cylinder2 r r -- $ 2D Primitives circle ::- ℝ -- ^ radius of the circle- -> SymbolicObj2 -- ^ resulting circle+ ℝ -- ^ radius of the circle+ -> SymbolicObj2 -- ^ resulting circle circle = Circle rectR ::- ℝ- -> ℝ2 -- ^ Bottom left corner- -> ℝ2 -- ^ Top right corner- -> SymbolicObj2 -- ^ Resulting square (bottom right = (0,0) )+ ℝ+ -> ℝ2 -- ^ Bottom left corner+ -> ℝ2 -- ^ Top right corner+ -> SymbolicObj2 -- ^ Resulting square (bottom right = (0,0) ) rectR = RectR polygonR ::- ℝ -- ^ Rouding of the polygon- -> [ℝ2] -- ^ Verticies of the polygon- -> SymbolicObj2 -- ^ Resulting polygon-+ ℝ -- ^ Rouding of the polygon+ -> [ℝ2] -- ^ Verticies of the polygon+ -> SymbolicObj2 -- ^ Resulting polygon polygonR = PolygonR +polygon :: [ℝ2] -> SymbolicObj2 polygon = polygonR 0 -- $ Shared Operations class Object obj vec | obj -> vec where- - -- | Translate an object by a vector of appropriate dimension. - translate :: - vec -- ^ Vector to translate by (Also: a is a vector, blah, blah)- -> obj -- ^ Object to translate- -> 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)+ -> obj -- ^ Object to translate+ -> obj -- ^ Resulting object - -- | Scale an object- scale :: - vec -- ^ Amount to scale by- -> obj -- ^ Object to scale- -> obj -- ^ Resulting scaled object - - -- | Complement an Object- complement :: - obj -- ^ Object to complement- -> obj -- ^ Result- - -- | Rounded union- unionR :: - ℝ -- ^ The radius of rounding- -> [obj] -- ^ objects to union- -> obj -- ^ Resulting object- - -- | Rounded minimum- intersectR :: - ℝ -- ^ The radius of rounding- -> [obj] -- ^ Objects to intersect- -> obj -- ^ Resulting object- - -- | Rounded difference- differenceR :: - ℝ -- ^ The radius of rounding- -> [obj] -- ^ Objects to difference - -> obj -- ^ Resulting object+ -- | Scale an object+ scale :: + vec -- ^ Amount to scale by+ -> obj -- ^ Object to scale+ -> obj -- ^ Resulting scaled object + + -- | Complement an Object+ complement :: + obj -- ^ Object to complement+ -> obj -- ^ Result+ + -- | Rounded union+ unionR :: + ℝ -- ^ The radius of rounding+ -> [obj] -- ^ objects to union+ -> obj -- ^ Resulting object+ + -- | Rounded minimum+ intersectR :: + ℝ -- ^ The radius of rounding+ -> [obj] -- ^ Objects to intersect+ -> obj -- ^ Resulting object+ + -- | Rounded difference+ differenceR :: + ℝ -- ^ The radius of rounding+ -> [obj] -- ^ Objects to difference + -> obj -- ^ Resulting object - -- | Outset an object.- outset :: - ℝ -- ^ distance to outset- -> obj -- ^ object to outset- -> obj -- ^ resulting object+ -- | Outset an object.+ outset :: + ℝ -- ^ distance to outset+ -> obj -- ^ object to outset+ -> obj -- ^ resulting object - -- | Make a shell of an object.- shell :: - ℝ -- ^ width of shell- -> obj -- ^ object to take shell of- -> obj -- ^ resulting shell+ -- | Make a shell of an object.+ shell :: + ℝ -- ^ width of shell+ -> obj -- ^ object to take shell of+ -> obj -- ^ resulting shell - -- | Get the bounding box an object- getBox :: - obj -- ^ Object to get box of- -> (vec, vec) -- ^ Bounding box+ -- | Get the bounding box an object+ getBox :: + obj -- ^ Object to get box of+ -> (vec, vec) -- ^ Bounding box - -- | Get the implicit function for an object- getImplicit :: - obj -- ^ Object to get implicit function of- -> (vec -> ℝ) -- ^ Implicit function+ -- | Get the implicit function for an object+ getImplicit :: + obj -- ^ Object to get implicit function of+ -> (vec -> ℝ) -- ^ Implicit function - implicit :: - (vec -> ℝ) -- ^ Implicit function- -> (vec, vec) -- ^ Bounding box- -> obj -- ^ Resulting object- + implicit :: + (vec -> ℝ) -- ^ Implicit function+ -> (vec, vec) -- ^ Bounding box+ -> obj -- ^ Resulting object+ instance Object SymbolicObj2 ℝ2 where- translate = Translate2- scale = Scale2- complement = Complement2- unionR = UnionR2- intersectR = IntersectR2- differenceR = DifferenceR2- outset = Outset2- shell = Shell2- getBox = getBox2- getImplicit = getImplicit2- implicit a b= EmbedBoxedObj2 (a,b)+ translate = Translate2+ scale = Scale2+ complement = Complement2+ unionR = UnionR2+ intersectR = IntersectR2+ differenceR = DifferenceR2+ outset = Outset2+ shell = Shell2+ getBox = getBox2+ getImplicit = getImplicit2+ implicit a b= EmbedBoxedObj2 (a,b) instance Object SymbolicObj3 ℝ3 where- translate = Translate3- scale = Scale3- complement = Complement3- unionR = UnionR3- intersectR = IntersectR3- differenceR = DifferenceR3- outset = Outset3- shell = Shell3- getBox = getBox3- getImplicit = getImplicit3- implicit a b= EmbedBoxedObj3 (a,b)+ translate = Translate3+ scale = Scale3+ complement = Complement3+ unionR = UnionR3+ intersectR = IntersectR3+ differenceR = DifferenceR3+ outset = Outset3+ shell = Shell3+ getBox = getBox3+ getImplicit = getImplicit3+ implicit a b= EmbedBoxedObj3 (a,b) union = unionR 0 difference = differenceR 0++--intersect :: forall obj vec. Object obj vec => [obj] -> obj intersect = intersectR 0 -- 3D operations +extrudeR :: ℝ -> SymbolicObj2 -> ℝ -> SymbolicObj3 extrudeR = ExtrudeR +extrudeRM :: ℝ+ -> Maybe (ℝ -> ℝ)+ -> Maybe (ℝ -> ℝ)+ -> Maybe (ℝ -> ℝ2)+ -> SymbolicObj2+ -> Either ℝ (ℝ2 -> ℝ)+ -> SymbolicObj3 extrudeRM = ExtrudeRM +rotateExtrude :: ℝ+ -> Maybe ℝ+ -> Either ℝ2 (ℝ -> ℝ2)+ -> Either ℝ (ℝ -> ℝ)+ -> SymbolicObj2+ -> SymbolicObj3 rotateExtrude = RotateExtrude +extrudeOnEdgeOf :: SymbolicObj2 -> SymbolicObj2 -> SymbolicObj3 extrudeOnEdgeOf = ExtrudeOnEdgeOf +rotate3 :: (ℝ, ℝ, ℝ) -> SymbolicObj3 -> SymbolicObj3 rotate3 = Rotate3 +rotate3V :: ℝ -> ℝ3 -> SymbolicObj3 -> SymbolicObj3 rotate3V = Rotate3V pack3 :: ℝ2 -> ℝ -> [SymbolicObj3] -> Maybe SymbolicObj3-pack3 (dx, dy) sep objs = - let- boxDropZ ((a,b,c),(d,e,f)) = ((a,b),(d,e))- withBoxes :: [(Box2, SymbolicObj3)]- withBoxes = map (\obj -> ( boxDropZ $ getBox3 obj, obj)) objs- in case pack ((0,0),(dy,dy)) sep withBoxes of- (a, []) -> Just $ union $ map (\((x,y),obj) -> translate (x,y,0) obj) a- _ -> Nothing- +pack3 (_dx, dy) sep objs = + let+ boxDropZ ((a,b,_),(d,e,_)) = ((a,b),(d,e))+ withBoxes :: [(Box2, SymbolicObj3)]+ withBoxes = map (\obj -> ( boxDropZ $ getBox3 obj, obj)) objs+ in case pack ((0,0),(dy,dy)) sep withBoxes of+ (a, []) -> Just $ union $ map (\((x,y),obj) -> translate (x,y,0) obj) a+ _ -> Nothing+ -- 2D operations +rotate :: ℝ -> SymbolicObj2 -> SymbolicObj2 rotate = Rotate2 pack2 :: ℝ2 -> ℝ -> [SymbolicObj2] -> Maybe SymbolicObj2-pack2 (dx, dy) sep objs = - let- withBoxes :: [(Box2, SymbolicObj2)]- withBoxes = map (\obj -> ( getBox2 obj, obj)) objs- in case pack ((0,0),(dy,dy)) sep withBoxes of- (a, []) -> Just $ union $ map (\((x,y),obj) -> translate (x,y) obj) a- _ -> Nothing+pack2 (_dx, dy) sep objs = + let+ withBoxes :: [(Box2, SymbolicObj2)]+ withBoxes = map (\obj -> ( getBox2 obj, obj)) objs+ in case pack ((0,0),(dy,dy)) sep withBoxes of+ (a, []) -> Just $ union $ map (\((x,y),obj) -> translate (x,y) obj) a+ _ -> Nothing
extopenscad.hs view
@@ -6,24 +6,20 @@ -- Let's make it convenient to run our extended openscad format code -- Let's be explicit about what we're getting from where :)-import System.IO (openFile, IOMode (ReadMode), hGetContents, hClose)-import Graphics.Implicit (runOpenscad, writeSVG, writeBinSTL, writeOBJ, writeSCAD3, writeSCAD2, writeGCodeHacklabLaser, writeTHREEJS, writePNG2, writePNG3)+import Graphics.Implicit (runOpenscad, writeSVG, writeBinSTL, writeOBJ, writeSCAD3, writeSCAD2, writeGCodeHacklabLaser, writePNG2, writePNG3) import Graphics.Implicit.ExtOpenScad.Definitions (OVal (ONum)) import Graphics.Implicit.ObjectUtil (getBox2, getBox3)-import Graphics.Implicit.Definitions (xmlErrorOn, errorMessage, SymbolicObj2, SymbolicObj3)+import Graphics.Implicit.Definitions (xmlErrorOn, SymbolicObj2, SymbolicObj3) import qualified Data.Map as Map hiding (null) import Data.Maybe as Maybe import Data.Char-import Data.Monoid (Monoid, mappend) import Data.Tuple (swap)-import Text.ParserCombinators.Parsec (errorPos, sourceLine)-import Text.ParserCombinators.Parsec.Error import Data.IORef (writeIORef) import Data.AffineSpace import Control.Applicative -- The following is needed to ensure backwards/forwards compatibility -- make sure we don't import (<>) in new versions.-import Options.Applicative (fullDesc, progDesc, header, info, helper, help, str, argument, switch, value, long, short, option, metavar, nullOption, reader, execParser, (&), Parser)+import Options.Applicative (fullDesc, progDesc, header, auto, info, helper, help, str, argument, switch, value, long, short, option, metavar, execParser, Parser) import System.FilePath -- Backwards compatibility with old versions of Data.Monoid:@@ -32,161 +28,158 @@ (<>) = mappend data ExtOpenScadOpts = ExtOpenScadOpts- { outputFile :: Maybe FilePath- , outputFormat :: Maybe OutputFormat- , resolution :: Maybe Float- , xmlError :: Bool- , inputFile :: FilePath- }+ { outputFile :: Maybe FilePath+ , outputFormat :: Maybe OutputFormat+ , resolution :: Maybe Float+ , xmlError :: Bool+ , inputFile :: FilePath+ } data OutputFormat- = SVG- | SCAD- | PNG- | GCode- | STL- | OBJ- deriving (Show, Eq, Ord)+ = SVG+ | SCAD+ | PNG+ | GCode+ | STL+ | OBJ+ deriving (Show, Eq, Ord) formatExtensions :: [(String, OutputFormat)] formatExtensions =- [ ("svg", SVG)- , ("scad", SCAD)- , ("png", PNG)- , ("ngc", GCode)- , ("stl", STL)- , ("obj", OBJ)- ]+ [ ("svg", SVG)+ , ("scad", SCAD)+ , ("png", PNG)+ , ("ngc", GCode)+ , ("stl", STL)+ , ("obj", OBJ)+ ] -readOutputFormat :: String -> Maybe OutputFormat-readOutputFormat ext = lookup (map toLower ext) formatExtensions+readOutputFormat :: Monad m => String -> m OutputFormat+readOutputFormat ext = case lookup (map toLower ext) formatExtensions of+ Nothing -> fail ("unknown extension: "++ext)+ Just x -> return x guessOutputFormat :: FilePath -> OutputFormat guessOutputFormat fileName =- maybe (error $ "Unrecognized output format: "<>ext) id- $ readOutputFormat $ tail ext- where- (_,ext) = splitExtension fileName+ Maybe.fromMaybe (error $ "Unrecognized output format: "<>ext)+ $ readOutputFormat $ tail ext+ where+ (_,ext) = splitExtension fileName extOpenScadOpts :: Parser ExtOpenScadOpts extOpenScadOpts =- ExtOpenScadOpts- <$> nullOption- ( short 'o'- <> long "output"- <> value Nothing- <> metavar "FILE"- <> reader (pure . str)- <> help "Output file name"- )- <*> nullOption- ( short 'f'- <> long "format"- <> value Nothing- <> metavar "FORMAT"- <> help "Output format"- <> reader (pure . readOutputFormat)- )- <*> option- ( short 'r'- <> long "resolution"- <> value Nothing- <> metavar "RES"- <> help "Approximation quality"- )- <*> switch- ( long "xml-error"- & help "Report XML errors"- )- <*> argument str ( metavar "FILE" )+ ExtOpenScadOpts+ <$> option (pure <$> str)+ ( short 'o'+ <> long "output"+ <> value Nothing+ <> metavar "FILE"+ <> help "Output file name"+ )+ <*> option (pure <$> (readOutputFormat =<< str))+ ( short 'f'+ <> long "format"+ <> value Nothing+ <> metavar "FORMAT"+ <> help "Output format"+ )+ <*> option (pure <$> auto)+ ( short 'r'+ <> long "resolution"+ <> value Nothing+ <> metavar "RES"+ <> help "Approximation quality"+ )+ <*> switch+ ( long "xml-error"+ <> help "Report XML errors"+ )+ <*> argument str ( metavar "FILE" ) getRes (Map.lookup "$res" -> Just (ONum res), _, _) = res getRes (varlookup, _, obj:_) =- let- ((x1,y1,z1),(x2,y2,z2)) = getBox3 obj- (x,y,z) = (x2-x1, y2-y1, z2-z1)- in case Maybe.fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of- ONum qual | qual > 0 -> min (minimum [x,y,z]/2) ((x*y*z/qual)**(1/3) / 22)- _ -> min (minimum [x,y,z]/2) ((x*y*z )**(1/3) / 22)+ let+ ((x1,y1,z1),(x2,y2,z2)) = getBox3 obj+ (x,y,z) = (x2-x1, y2-y1, z2-z1)+ in case Maybe.fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of+ ONum qual | qual > 0 -> min (minimum [x,y,z]/2) ((x*y*z/qual)**(1/3) / 22)+ _ -> min (minimum [x,y,z]/2) ((x*y*z )**(1/3) / 22) getRes (varlookup, obj:_, _) =- let- (p1,p2) = getBox2 obj- (x,y) = p2 .-. p1- in case Maybe.fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of- ONum qual | qual > 0 -> min (min x y/2) ((x*y/qual)**0.5 / 30)- _ -> min (min x y/2) ((x*y )**0.5 / 30)+ let+ (p1,p2) = getBox2 obj+ (x,y) = p2 .-. p1+ in case Maybe.fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of+ ONum qual | qual > 0 -> min (min x y/2) (sqrt (x*y/qual) / 30)+ _ -> min (min x y/2) (sqrt (x*y ) / 30) getRes _ = 1 export3 :: Maybe OutputFormat -> Float -> FilePath -> SymbolicObj3 -> IO () export3 posFmt res output obj =- case posFmt of- Just STL -> writeBinSTL res output obj- Just SCAD -> writeSCAD3 res output obj- Just OBJ -> writeOBJ res output obj- Just PNG -> writePNG3 res output obj- Nothing -> writeBinSTL res output obj- Just fmt -> putStrLn $ "Unrecognized 3D format: "<>show fmt+ case posFmt of+ Just STL -> writeBinSTL res output obj+ Just SCAD -> writeSCAD3 res output obj+ Just OBJ -> writeOBJ res output obj+ Just PNG -> writePNG3 res output obj+ Nothing -> writeBinSTL res output obj+ Just fmt -> putStrLn $ "Unrecognized 3D format: "<>show fmt export2 :: Maybe OutputFormat -> Float -> FilePath -> SymbolicObj2 -> IO () export2 posFmt res output obj =- case posFmt of- Just SVG -> writeSVG res output obj- Just SCAD -> writeSCAD2 res output obj- Just PNG -> writePNG2 res output obj- Just GCode -> writeGCodeHacklabLaser res output obj- Nothing -> writeSVG res output obj- Just fmt -> putStrLn $ "Unrecognized 2D format: "<>show fmt+ case posFmt of+ Just SVG -> writeSVG res output obj+ Just SCAD -> writeSCAD2 res output obj+ Just PNG -> writePNG2 res output obj+ Just GCode -> writeGCodeHacklabLaser res output obj+ Nothing -> writeSVG res output obj+ Just fmt -> putStrLn $ "Unrecognized 2D format: "<>show fmt main :: IO() main = do- args <- execParser- $ info (helper <*> extOpenScadOpts)- ( fullDesc- <> progDesc "Extended OpenSCAD"- <> header "extopenscad - Extended OpenSCAD"- )- writeIORef xmlErrorOn (xmlError args)+ args <- execParser+ $ info (helper <*> extOpenScadOpts)+ ( fullDesc+ <> progDesc "Extended OpenSCAD"+ <> header "extopenscad - Extended OpenSCAD"+ )+ writeIORef xmlErrorOn (xmlError args) - content <- readFile (inputFile args)- let format = - case () of- _ | Just fmt <- outputFormat args -> Just $ fmt- _ | Just file <- outputFile args -> Just $ guessOutputFormat file- _ -> Nothing- case runOpenscad content of- Left err -> putStrLn $ show $ err- Right openscadProgram -> do- s@(vars, obj2s, obj3s) <- openscadProgram- let res = maybe (getRes s) id (resolution args)- let basename = fst (splitExtension $ inputFile args)- let posDefExt = case format of- Just f -> lookup f (map swap formatExtensions)- Nothing -> Nothing -- We don't know the format -- it will be 2D/3D default- {-let Just defExtension = lookup format (map swap formatExtensions)- in maybe (fst (splitExtension $ inputFile args)<>"."<>defExtension) id- $ outputFile args-}- case (obj2s, obj3s) of- ([], [obj]) -> do- let output = fromMaybe - (basename ++ "." ++ fromMaybe "stl" posDefExt)- (outputFile args)- putStrLn $ "Rendering 3D object to " ++ output- putStrLn $ "With resolution " ++ show res- putStrLn $ "In box " ++ show (getBox3 obj)- putStrLn $ show obj- export3 format res output obj- ([obj], []) -> do- let output = fromMaybe - (basename ++ "." ++ fromMaybe "stl" posDefExt)- (outputFile args)- putStrLn $ "Rendering 2D object to " ++ output- putStrLn $ "With resolution " ++ show res- putStrLn $ "In box " ++ show (getBox2 obj)- putStrLn $ show obj- export2 format res output obj- ([], []) -> putStrLn "No objects to render"- _ -> putStrLn "Multiple objects, what do you want to render?"+ content <- readFile (inputFile args)+ let format = case () of+ _ | Just fmt <- outputFormat args -> Just fmt+ _ | Just file <- outputFile args -> Just $ guessOutputFormat file+ _ -> Nothing+ case runOpenscad content of+ Left err -> print err+ Right openscadProgram -> do+ s@(_vars, obj2s, obj3s) <- openscadProgram+ let res = Maybe.fromMaybe (getRes s) (resolution args)+ let basename = fst (splitExtension $ inputFile args)+ let posDefExt = case format of+ Just f -> lookup f (map swap formatExtensions)+ Nothing -> Nothing -- We don't know the format -- it will be 2D/3D default+ {-let Just defExtension = lookup format (map swap formatExtensions)+ in maybe (fst (splitExtension $ inputFile args)<>"."<>defExtension) id+ $ outputFile args-}+ case (obj2s, obj3s) of+ ([], [obj]) -> do+ let output = fromMaybe + (basename ++ "." ++ fromMaybe "stl" posDefExt)+ (outputFile args)+ putStrLn $ "Rendering 3D object to " ++ output+ putStrLn $ "With resolution " ++ show res+ putStrLn $ "In box " ++ show (getBox3 obj)+ export3 format res output obj+ ([obj], []) -> do+ let output = fromMaybe + (basename ++ "." ++ fromMaybe "stl" posDefExt)+ (outputFile args)+ putStrLn $ "Rendering 2D object to " ++ output+ putStrLn $ "With resolution " ++ show res+ putStrLn $ "In box " ++ show (getBox2 obj)+ export2 format res output obj+ ([], []) -> putStrLn "No objects to render"+ _ -> putStrLn "Multiple objects, what do you want to render?"
implicit.cabal view
@@ -1,5 +1,5 @@ Name: implicit-Version: 0.0.3+Version: 0.0.4 cabal-version: >= 1.6 Synopsis: Math-inspired programmatic 2&3D CAD: CSG, bevels, and shells; gcode export.. Description: A math-inspired programmatic CAD library in haskell.@@ -9,7 +9,7 @@ License: GPL License-file: LICENSE Author: Christopher Olah-Maintainer: Christopher Olah <chris@colah.ca>+Maintainer: Mike MacHenry <mike.machenry@gmail.com>, Christopher Olah <chris@colah.ca> Homepage: https://github.com/colah/ImplicitCAD build-type: Simple Category: Graphics@@ -20,7 +20,7 @@ base >= 3 && < 5, filepath, directory,- optparse-applicative,+ optparse-applicative >= 0.10.0, parsec, unordered-containers, parallel,@@ -34,7 +34,8 @@ blaze-markup, blaze-svg, storable-endian,- JuicyPixels+ JuicyPixels,+ NumInstances ghc-options: -O2 -optc-O3