diff --git a/Graphics/Implicit.hs b/Graphics/Implicit.hs --- a/Graphics/Implicit.hs +++ b/Graphics/Implicit.hs @@ -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 :) diff --git a/Graphics/Implicit/Definitions.hs b/Graphics/Implicit/Definitions.hs --- a/Graphics/Implicit/Definitions.hs +++ b/Graphics/Implicit/Definitions.hs @@ -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 = "" - -- | 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 " ++ show 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 $ "" ++ msg' ++ "" - else putStrLn $ dropXML False False $ msg' - return () + useXML <- readIORef xmlErrorOn + let + msg' = "At line " ++ show 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 "" ++ msg' ++ "" + else dropXML False False msg' + return () + +-- HACK: This needs to be fixed correctly someday +instance Show (a -> b) where + show _ = "" diff --git a/Graphics/Implicit/Export.hs b/Graphics/Implicit/Export.hs --- a/Graphics/Implicit/Export.hs +++ b/Graphics/Implicit/Export.hs @@ -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 -} -} diff --git a/Graphics/Implicit/Export/Definitions.hs b/Graphics/Implicit/Export/Definitions.hs --- a/Graphics/Implicit/Export/Definitions.hs +++ b/Graphics/Implicit/Export/Definitions.hs @@ -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 diff --git a/Graphics/Implicit/Export/MarchingSquares.hs b/Graphics/Implicit/Export/MarchingSquares.hs --- a/Graphics/Implicit/Export/MarchingSquares.hs +++ b/Graphics/Implicit/Export/MarchingSquares.hs @@ -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') -} diff --git a/Graphics/Implicit/Export/MarchingSquaresFill.hs b/Graphics/Implicit/Export/MarchingSquaresFill.hs --- a/Graphics/Implicit/Export/MarchingSquaresFill.hs +++ b/Graphics/Implicit/Export/MarchingSquaresFill.hs @@ -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]] diff --git a/Graphics/Implicit/Export/NormedTriangleMeshFormats.hs b/Graphics/Implicit/Export/NormedTriangleMeshFormats.hs --- a/Graphics/Implicit/Export/NormedTriangleMeshFormats.hs +++ b/Graphics/Implicit/Export/NormedTriangleMeshFormats.hs @@ -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" diff --git a/Graphics/Implicit/Export/PolylineFormats.hs b/Graphics/Implicit/Export/PolylineFormats.hs --- a/Graphics/Implicit/Export/PolylineFormats.hs +++ b/Graphics/Implicit/Export/PolylineFormats.hs @@ -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] diff --git a/Graphics/Implicit/Export/RayTrace.hs b/Graphics/Implicit/Export/RayTrace.hs --- a/Graphics/Implicit/Export/RayTrace.hs +++ b/Graphics/Implicit/Export/RayTrace.hs @@ -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 diff --git a/Graphics/Implicit/Export/Render.hs b/Graphics/Implicit/Export/Render.hs --- a/Graphics/Implicit/Export/Render.hs +++ b/Graphics/Implicit/Export/Render.hs @@ -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 diff --git a/Graphics/Implicit/Export/Render/Definitions.hs b/Graphics/Implicit/Export/Render/Definitions.hs --- a/Graphics/Implicit/Export/Render/Definitions.hs +++ b/Graphics/Implicit/Export/Render/Definitions.hs @@ -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 diff --git a/Graphics/Implicit/Export/Render/GetLoops.hs b/Graphics/Implicit/Export/Render/GetLoops.hs --- a/Graphics/Implicit/Export/Render/GetLoops.hs +++ b/Graphics/Implicit/Export/Render/GetLoops.hs @@ -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]) diff --git a/Graphics/Implicit/Export/Render/GetSegs.hs b/Graphics/Implicit/Export/Render/GetSegs.hs --- a/Graphics/Implicit/Export/Render/GetSegs.hs +++ b/Graphics/Implicit/Export/Render/GetSegs.hs @@ -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) diff --git a/Graphics/Implicit/Export/Render/HandlePolylines.hs b/Graphics/Implicit/Export/Render/HandlePolylines.hs --- a/Graphics/Implicit/Export/Render/HandlePolylines.hs +++ b/Graphics/Implicit/Export/Render/HandlePolylines.hs @@ -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 -} diff --git a/Graphics/Implicit/Export/Render/HandleSquares.hs b/Graphics/Implicit/Export/Render/HandleSquares.hs --- a/Graphics/Implicit/Export/Render/HandleSquares.hs +++ b/Graphics/Implicit/Export/Render/HandleSquares.hs @@ -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)] diff --git a/Graphics/Implicit/Export/Render/Interpolate.hs b/Graphics/Implicit/Export/Render/Interpolate.hs --- a/Graphics/Implicit/Export/Render/Interpolate.hs +++ b/Graphics/Implicit/Export/Render/Interpolate.hs @@ -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 diff --git a/Graphics/Implicit/Export/Render/RefineSegs.hs b/Graphics/Implicit/Export/Render/RefineSegs.hs --- a/Graphics/Implicit/Export/Render/RefineSegs.hs +++ b/Graphics/Implicit/Export/Render/RefineSegs.hs @@ -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 -} diff --git a/Graphics/Implicit/Export/Render/TesselateLoops.hs b/Graphics/Implicit/Export/Render/TesselateLoops.hs --- a/Graphics/Implicit/Export/Render/TesselateLoops.hs +++ b/Graphics/Implicit/Export/Render/TesselateLoops.hs @@ -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) diff --git a/Graphics/Implicit/Export/Symbolic/Rebound2.hs b/Graphics/Implicit/Export/Symbolic/Rebound2.hs --- a/Graphics/Implicit/Export/Symbolic/Rebound2.hs +++ b/Graphics/Implicit/Export/Symbolic/Rebound2.hs @@ -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))) diff --git a/Graphics/Implicit/Export/Symbolic/Rebound3.hs b/Graphics/Implicit/Export/Symbolic/Rebound3.hs --- a/Graphics/Implicit/Export/Symbolic/Rebound3.hs +++ b/Graphics/Implicit/Export/Symbolic/Rebound3.hs @@ -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))) diff --git a/Graphics/Implicit/Export/SymbolicFormats.hs b/Graphics/Implicit/Export/SymbolicFormats.hs --- a/Graphics/Implicit/Export/SymbolicFormats.hs +++ b/Graphics/Implicit/Export/SymbolicFormats.hs @@ -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) <> "]" diff --git a/Graphics/Implicit/Export/SymbolicObj2.hs b/Graphics/Implicit/Export/SymbolicObj2.hs --- a/Graphics/Implicit/Export/SymbolicObj2.hs +++ b/Graphics/Implicit/Export/SymbolicObj2.hs @@ -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 diff --git a/Graphics/Implicit/Export/SymbolicObj3.hs b/Graphics/Implicit/Export/SymbolicObj3.hs --- a/Graphics/Implicit/Export/SymbolicObj3.hs +++ b/Graphics/Implicit/Export/SymbolicObj3.hs @@ -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 diff --git a/Graphics/Implicit/Export/TextBuilderUtils.hs b/Graphics/Implicit/Export/TextBuilderUtils.hs --- a/Graphics/Implicit/Export/TextBuilderUtils.hs +++ b/Graphics/Implicit/Export/TextBuilderUtils.hs @@ -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 diff --git a/Graphics/Implicit/Export/Util.hs b/Graphics/Implicit/Export/Util.hs --- a/Graphics/Implicit/Export/Util.hs +++ b/Graphics/Implicit/Export/Util.hs @@ -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] -} diff --git a/Graphics/Implicit/ExtOpenScad.hs b/Graphics/Implicit/ExtOpenScad.hs --- a/Graphics/Implicit/ExtOpenScad.hs +++ b/Graphics/Implicit/ExtOpenScad.hs @@ -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 diff --git a/Graphics/Implicit/ExtOpenScad/Default.hs b/Graphics/Implicit/ExtOpenScad/Default.hs --- a/Graphics/Implicit/ExtOpenScad/Default.hs +++ b/Graphics/Implicit/ExtOpenScad/Default.hs @@ -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 ++ "."] diff --git a/Graphics/Implicit/ExtOpenScad/Definitions.hs b/Graphics/Implicit/ExtOpenScad/Definitions.hs --- a/Graphics/Implicit/ExtOpenScad/Definitions.hs +++ b/Graphics/Implicit/ExtOpenScad/Definitions.hs @@ -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) = "" - show (OModule _) = "module" - show (OError msgs) = "Execution Error:\n" ++ foldl1 (\a b -> a ++ "\n" ++ b) msgs - show (OObj2 obj) = "" - show (OObj3 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) = "" + show (OModule _) = "module" + show (OError msgs) = "Execution Error:\n" ++ foldl1 (\a b -> a ++ "\n" ++ b) msgs + show (OObj2 obj) = "" + show (OObj3 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) diff --git a/Graphics/Implicit/ExtOpenScad/Eval/Expr.hs b/Graphics/Implicit/ExtOpenScad/Eval/Expr.hs --- a/Graphics/Implicit/ExtOpenScad/Eval/Expr.hs +++ b/Graphics/Implicit/ExtOpenScad/Eval/Expr.hs @@ -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 diff --git a/Graphics/Implicit/ExtOpenScad/Eval/Statement.hs b/Graphics/Implicit/ExtOpenScad/Eval/Statement.hs --- a/Graphics/Implicit/ExtOpenScad/Eval/Statement.hs +++ b/Graphics/Implicit/ExtOpenScad/Eval/Statement.hs @@ -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 diff --git a/Graphics/Implicit/ExtOpenScad/Parser/Expr.hs b/Graphics/Implicit/ExtOpenScad/Parser/Expr.hs --- a/Graphics/Implicit/ExtOpenScad/Parser/Expr.hs +++ b/Graphics/Implicit/ExtOpenScad/Parser/Expr.hs @@ -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) diff --git a/Graphics/Implicit/ExtOpenScad/Parser/Statement.hs b/Graphics/Implicit/ExtOpenScad/Parser/Statement.hs --- a/Graphics/Implicit/ExtOpenScad/Parser/Statement.hs +++ b/Graphics/Implicit/ExtOpenScad/Parser/Statement.hs @@ -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 diff --git a/Graphics/Implicit/ExtOpenScad/Parser/Util.hs b/Graphics/Implicit/ExtOpenScad/Parser/Util.hs --- a/Graphics/Implicit/ExtOpenScad/Parser/Util.hs +++ b/Graphics/Implicit/ExtOpenScad/Parser/Util.hs @@ -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 + ) diff --git a/Graphics/Implicit/ExtOpenScad/Primitives.hs b/Graphics/Implicit/ExtOpenScad/Primitives.hs --- a/Graphics/Implicit/ExtOpenScad/Primitives.hs +++ b/Graphics/Implicit/ExtOpenScad/Primitives.hs @@ -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) diff --git a/Graphics/Implicit/ExtOpenScad/Util/ArgParser.hs b/Graphics/Implicit/ExtOpenScad/Util/ArgParser.hs --- a/Graphics/Implicit/ExtOpenScad/Util/ArgParser.hs +++ b/Graphics/Implicit/ExtOpenScad/Util/ArgParser.hs @@ -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! diff --git a/Graphics/Implicit/ExtOpenScad/Util/OVal.hs b/Graphics/Implicit/ExtOpenScad/Util/OVal.hs --- a/Graphics/Implicit/ExtOpenScad/Util/OVal.hs +++ b/Graphics/Implicit/ExtOpenScad/Util/OVal.hs @@ -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 diff --git a/Graphics/Implicit/ExtOpenScad/Util/StateC.hs b/Graphics/Implicit/ExtOpenScad/Util/StateC.hs --- a/Graphics/Implicit/ExtOpenScad/Util/StateC.hs +++ b/Graphics/Implicit/ExtOpenScad/Util/StateC.hs @@ -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 diff --git a/Graphics/Implicit/MathUtil.hs b/Graphics/Implicit/MathUtil.hs --- a/Graphics/Implicit/MathUtil.hs +++ b/Graphics/Implicit/MathUtil.hs @@ -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 [] _ = ([], []) diff --git a/Graphics/Implicit/ObjectUtil/GetBox2.hs b/Graphics/Implicit/ObjectUtil/GetBox2.hs --- a/Graphics/Implicit/ObjectUtil/GetBox2.hs +++ b/Graphics/Implicit/ObjectUtil/GetBox2.hs @@ -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) diff --git a/Graphics/Implicit/ObjectUtil/GetBox3.hs b/Graphics/Implicit/ObjectUtil/GetBox3.hs --- a/Graphics/Implicit/ObjectUtil/GetBox3.hs +++ b/Graphics/Implicit/ObjectUtil/GetBox3.hs @@ -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')) diff --git a/Graphics/Implicit/ObjectUtil/GetImplicit2.hs b/Graphics/Implicit/ObjectUtil/GetImplicit2.hs --- a/Graphics/Implicit/ObjectUtil/GetImplicit2.hs +++ b/Graphics/Implicit/ObjectUtil/GetImplicit2.hs @@ -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 diff --git a/Graphics/Implicit/ObjectUtil/GetImplicit3.hs b/Graphics/Implicit/ObjectUtil/GetImplicit3.hs --- a/Graphics/Implicit/ObjectUtil/GetImplicit3.hs +++ b/Graphics/Implicit/ObjectUtil/GetImplicit3.hs @@ -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 diff --git a/Graphics/Implicit/Primitives.hs b/Graphics/Implicit/Primitives.hs --- a/Graphics/Implicit/Primitives.hs +++ b/Graphics/Implicit/Primitives.hs @@ -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 diff --git a/extopenscad.hs b/extopenscad.hs --- a/extopenscad.hs +++ b/extopenscad.hs @@ -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?" diff --git a/implicit.cabal b/implicit.cabal --- a/implicit.cabal +++ b/implicit.cabal @@ -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 +Maintainer: Mike MacHenry , Christopher Olah 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