diff --git a/Graphics/Implicit.hs b/Graphics/Implicit.hs --- a/Graphics/Implicit.hs +++ b/Graphics/Implicit.hs @@ -1,39 +1,144 @@ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU GPL, see LICENSE -{- The sole purpose of this file it to pass on the +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +{- The sole purpose of this file it to pass on the functionality we want to be accessible to the end user. -} module Graphics.Implicit( -- Operations - translate, + translate, scale, complement, union, intersect, difference, unionR, intersectR, differenceR, shell, - slice, - bubble, - extrude, + --slice, extrudeR, extrudeOnEdgeOf, -- Primitives sphere, - cube, + rect3R, circle, cylinder, - square, - regularPolygon, - zsurface, + rectR, + --regularPolygon, + --zsurface, polygon, - --ellipse, -- Export writeSVG, - writeSTL + writeSTL, + runOpenscad ) where -import Graphics.Implicit.Definitions -import Graphics.Implicit.Primitives -import Graphics.Implicit.Operations -import Graphics.Implicit.Export +-- Let's be explicit about where things come from :) +import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, SymbolicObj2, SymbolicObj3) +import qualified Graphics.Implicit.Primitives as Prim +import qualified Graphics.Implicit.Export as Export +import Graphics.Implicit.ExtOpenScad (runOpenscad) +import Graphics.Implicit.Operations + (translate, scale, complement, + union, intersect, difference, + unionR, intersectR, differenceR, + extrudeR, extrudeOnEdgeOf, shell) + +-- The versions of objects that should be used by default. +-- Import Graphics.Implicit.Primitives to override + +type DObj3 = SymbolicObj3 +type DObj2 = SymbolicObj2 + +-- We're going to force some of the types to be less flexible +-- than they are for ease of use for the end user... + +writeSTL :: + ℝ -- ^ Resolution + -> FilePath -- ^ STL file to write to + -> DObj3 -- ^ 3D object to write + -> IO() -- ^ Writing action! + +writeSTL = Export.writeSTL + +writeSVG :: + ℝ -- ^ Resolution + -> FilePath -- ^ SVG File to be written to + -> DObj2 -- ^ 2D object to write + -> IO() -- ^ Writing action! + +writeSVG = Export.writeSVG + + +sphere :: + ℝ -- ^ Radius of the sphere + -> DObj3 -- ^ Resulting sphere +sphere = Prim.sphere +rect3R :: + ℝ -- ^ Radius of roudning + -> ℝ3 -- ^ bot-left-out corner + -> ℝ3 -- ^ top-right-in corner + -> DObj3 -- ^ Resuting 3D rect +rect3R = Prim.rect3R + +cylinder2 :: + ℝ -- ^ Radius of the cylinder + -> ℝ -- ^ Second radius of the cylinder + -> ℝ -- ^ Height of the cylinder + -> DObj3 -- ^ Resulting cylinder +cylinder2 = Prim.cylinder2 + +circle :: + ℝ -- ^ radius of the circle + -> DObj2 -- ^ resulting circle +circle = Prim.circle + +rectR :: + ℝ -- ^ Radius of rounding + -> ℝ2 -- ^ (x1, y1) + -> ℝ2 -- ^ (x2 ,y2) + -> DObj2 -- ^ rect between (x1,y1) and (x2,y2) +rectR = Prim.rectR + +polygon :: + [ℝ2] -- ^ Verticies of the polygon + -> DObj2 -- ^ Resulting polygon +polygon = Prim.polygonR 0 + + + +cylinder :: + ℝ -- ^ Radius of the cylinder + -> ℝ -- ^ Height of the cylinder + -> DObj3 -- ^ Resulting cylinder +cylinder r h = cylinder2 r r h + +cylinderC :: + ℝ -- ^ Radius of the cylinder + -> ℝ -- ^ Height of the cylinder + -> DObj3 -- ^ Resulting cylinder +cylinderC r h = translate (0,0,-h/2.0) $ cylinder r h + + +cylinder2C :: + ℝ -- ^ Radius of the cylinder + -> ℝ -- ^ Second radius of the cylinder + -> ℝ -- ^ Height of the cylinder + -> DObj3 -- ^ Resulting cylinder +cylinder2C r1 r2 h = translate (0,0,-h/2.0) $ cylinder2 r1 r2 h + + + + + + + + + +-- This function is commented out because it doesn't obey the magnitude requirement. +-- Refer to blog post. +-- It needs to be fixed at some point, but the math is somewhat non-trivial. +--ellipse :: ℝ -> ℝ -> Obj2 +--ellipse a b +-- | a < b = \(x,y) -> sqrt ((b/a*x)**2 + y**2) - a +-- | otherwise = \(x,y) -> sqrt (x**2 + (a/b*y)**2) - b diff --git a/Graphics/Implicit/Definitions.hs b/Graphics/Implicit/Definitions.hs --- a/Graphics/Implicit/Definitions.hs +++ b/Graphics/Implicit/Definitions.hs @@ -15,10 +15,17 @@ -- eg. [(0,0), (0.5,1), (1,0)] ---> /\ type Polyline = [ℝ2] +-- | A triangle (a,b,c) = a trinagle with vertices a, b and c +type Triangle = (ℝ3, ℝ3, ℝ3) + +-- | A triangle mesh is a bunch of triangles :) +type TriangleMesh = [Triangle] + -- $ In Implicit CAD, we consider objects as functions -- of `outwardness'. The boundary is 0, negative is the -- interior and positive the exterior. The magnitude is -- how far out or in. +-- For more details, refer to http://christopherolah.wordpress.com/2011/11/06/manipulation-of-implicit-functions-with-an-eye-on-cad/ -- | A 2D object type Obj2 = (ℝ2 -> ℝ) @@ -26,5 +33,81 @@ -- | A 3D object type Obj3 = (ℝ3 -> ℝ) +-- | A 2D box +type Box2 = (ℝ2, ℝ2) +-- | A 3D box +type Box3 = (ℝ3, ℝ3) + +-- | Boxed 2D object +type Boxed2 a = (a, Box2) + +-- | Boxed 3D object +type Boxed3 a = (a, Box3) + +type BoxedObj2 = Boxed2 Obj2 +type BoxedObj3 = Boxed3 Obj3 + +-- | A symbolic 2D object format. +-- We want to have a symbolic object so that we can +-- 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 ℝ SymbolicObj2 + | Rotate2 ℝ SymbolicObj2 + -- Boundary mods + | Outset2 ℝ SymbolicObj2 + | Shell2 ℝ SymbolicObj2 + -- Misc + | EmbedBoxedObj2 BoxedObj2 + deriving Show + +-- | A symbolic 3D format! + +data SymbolicObj3 = + -- Some simple primitives + Rect3R ℝ ℝ3 ℝ3 + | Sphere ℝ + -- Some (rounded) CSG + | Complement3 SymbolicObj3 + | UnionR3 ℝ [SymbolicObj3] + | IntersectR3 ℝ [SymbolicObj3] + | DifferenceR3 ℝ [SymbolicObj3] + -- Some simple transofrms + | Translate3 ℝ3 SymbolicObj3 + | Scale3 ℝ SymbolicObj3 + | Rotate3 (ℝ,ℝ,ℝ) SymbolicObj3 + -- Some boundary based transforms + | Outset3 ℝ SymbolicObj3 + | Shell3 ℝ SymbolicObj3 + -- Misc + | EmbedBoxedObj3 BoxedObj3 + -- 2D based + | ExtrudeR ℝ SymbolicObj2 ℝ + | ExtrudeRotateR ℝ ℝ SymbolicObj2 ℝ + | ExtrudeRMod ℝ (ℝ -> ℝ2 -> ℝ2) SymbolicObj2 ℝ + | ExtrudeOnEdgeOf SymbolicObj2 SymbolicObj2 + deriving Show + +-- | Rectiliniar 2D set +type Rectiliniar2 = [Box2] + +-- | Rectiliniar 2D set +type Rectiliniar3 = [Box3] + +-- | Make ALL the functions Showable! +-- This is very handy when testing functions in interactive mode... +instance Show (a -> b) where + show f = "" diff --git a/Graphics/Implicit/Export.hs b/Graphics/Implicit/Export.hs --- a/Graphics/Implicit/Export.hs +++ b/Graphics/Implicit/Export.hs @@ -4,10 +4,48 @@ module Graphics.Implicit.Export where import Graphics.Implicit.Definitions -import Graphics.Implicit.Tracing -import System.IO +--import Graphics.Implicit.Operations (slice) +import System.IO (writeFile) +-- class DiscreteApproxable +import Graphics.Implicit.Export.Definitions + +-- instances of DiscreteApproxable... +import Graphics.Implicit.Export.BoxedObj2 +import Graphics.Implicit.Export.BoxedObj3 +import Graphics.Implicit.Export.SymbolicObj2 +import Graphics.Implicit.Export.SymbolicObj3 + +-- File formats +import qualified Graphics.Implicit.Export.PolylineFormats as PolylineFormats +import qualified Graphics.Implicit.Export.TriangleMeshFormats as TriangleMeshFormats + +-- Write an object in a given formet... + +writeObject :: (DiscreteAproxable obj aprox) => + ℝ -- ^ Resolution + -> (aprox -> String) -- ^ File Format (Function that formats) + -> FilePath -- ^ File Name + -> obj -- ^ Object to render + -> IO() -- ^ Writing Action! + +writeObject res format filename obj = writeFile filename text + where + aprox = discreteAprox res obj + text = format aprox + +-- Now functions to write it in specific formats + +writeSVG res = writeObject res PolylineFormats.svg + +writeSTL res = writeObject res TriangleMeshFormats.stl + +writeGCodeHacklabLaser res = writeObject res PolylineFormats.hacklabLaserGCode + + + +{- 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 @@ -31,148 +69,54 @@ [[ obj (x,y) | x <- [x1, x1+res.. x2] ] | y <- [y1, y1+res.. y2] ] hClose out --- | Write an SVG of a 2D object -writeSVG :: - ℝ2 -- ^ lower corner of bounding box - -> ℝ2 -- ^ upper corner of bounding box - -> ℝ -- ^ resolution of rendering - -> String -- ^ Filename to write SVG to - -> Obj2 -- ^ 2D object to render as SVG - -> IO () -- ^ Resulting IO action that will write SVG -writeSVG (x1,y1) (x2,y2) d name obj = - let - -- Note that 0,0 is the upper right hand corner and that positive is down - grid = [(obj (x,-y), obj (x+d,-y), obj (x+d,-(y+d)), obj (x,-(y+d)), obj (x+d/2,-(y+d/2)) , (x-x1,y-y1), d ) | x <- [x1, x1+d.. x2], y <- [y1, y1 +d.. y2] ] - multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLines $ concat $ map getLineSeg grid - svglines = concat $ map (\line -> - " " " ++ show x ++ "," ++ show y) line) - ++ "\" style=\"stroke:rgb(0,0,255);stroke-width:1;fill:none;\"/> \n" ) - multilines - text = " \n" - ++ svglines - ++ " " - in do - writeFile name text - --- | Write an SVG of a 2D object (uses parallel algorithms) -writeSVG2 :: - ℝ2 -- ^ lower corner of bounding box - -> ℝ2 -- ^ upper corner of bounding box - -> ℝ -- ^ resolution of rendering - -> String -- ^ Filename to write SVG to - -> Obj2 -- ^ 2D object to render as SVG - -> IO () -- ^ Resulting IO action that will write SVG - -writeSVG2 (x1,y1) (x2,y2) d name obj = - let - grid = [[getLineSeg (obj (x,-y), obj (x+d,-y), obj (x+d,-(y+d)), obj (x,-(y+d)), obj (x+d/2,-(y+d/2)) , (x-x1,y-y1), d ) | x <- [x1, x1+d.. x2]] | y <- [y1, y1 +d.. y2] ] - multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLinesP grid - svglines = concat $ map (\line -> - " " " ++ show x ++ "," ++ show y) line) - ++ "\" style=\"stroke:rgb(0,0,255);stroke-width:1;fill:none;\"/> \n" ) - multilines - text = " \n" - ++ svglines - ++ " " - in do - writeFile name text - - - -writeGCode :: - ℝ2 -- ^ lower corner of bounding box - -> ℝ2 -- ^ upper corner of bounding box - -> ℝ -- ^ resolution of rendering - -> FilePath -- ^ Filename to write gcode to - -> Obj2 -- ^ 2D object to make gcode for - -> IO () -- ^ Resulting IO action that will write gcode - -writeGCode (x1,y1) (x2,y2) d name obj = - let - multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLines $ concat $ map getLineSeg [(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 ) | x <- [x1, x1+d.. x2], y <- [y1, y1 +d.. y2] ] - gcodeHeader = "(generated by ImplicitCAD)\nM3\nG21 (units=mm)\nG00 Z5.0 (tool is off)\n\n" - gcodeFooter = "\n%\n" - gcodeXY :: ℝ2 -> [Char] - gcodeXY (x,y) = "X"++ show x ++" Y"++ show y - interpretPolyline (start:next:others) = - "G00 "++ gcodeXY start ++ "\n" - ++ "G01 Z-1.0 F100.0\n" - ++ "G01 " ++ gcodeXY next ++ " Z-1.0 F400.0\n" - ++ concat (map (\p -> "G01 " ++ (gcodeXY p) ++ " Z-1.0\n") others) - ++ "G00 Z5.0\n\n" - text = gcodeHeader - ++ (concat $ map interpretPolyline multilines) - ++ gcodeFooter - in do - writeFile name text - -writeGCodeHacklabLaser :: - ℝ2 -- ^ lower corner of bounding box - -> ℝ2 -- ^ upper corner of bounding box +{-writeGCodeMakerbot :: + ℝ3 -- ^ lower corner of bounding box + -> ℝ3 -- ^ upper corner of bounding box -> ℝ -- ^ resolution of rendering -> FilePath -- ^ Filename to write gcode to - -> Obj2 -- ^ 2D object to make gcode for + -> Obj3 -- ^ 3D object to make gcode for -> IO () -- ^ Resulting IO action that will write gcode -writeGCodeHacklabLaser (x1,y1) (x2,y2) d name obj = + writeGCodeMakerbot (x1,y1,z1) (x2,y2,z2) d name obj = let - multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLines $ concat $ map getLineSeg [(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 ) | x <- [x1, x1+d.. x2], y <- [y1, y1 +d.. y2] ] + 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 hacklab wiki example)\n" - ++"M63 P0 (laser off)\n" - ++"G0 Z0.002 (laser off)\n" - ++"G21 (units=mm)\n" - ++"F400 (set feedrate)\n" - ++"M3 S1 (enable laser)\n" - ++"\n" + "(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 = - "M5 (disable laser)\n" + "M104 S0 (extruder heating off!)\n" ++"G00 X0.0 Y0.0 (move to 0)\n" ++"M2 (end)" - gcodeXY :: ℝ2 -> [Char] - gcodeXY (x,y) = "X"++ show x ++" Y"++ show y + gcodeXYZ :: ℝ3 -> [Char] + gcodeXYZ (x,y,z) = "X"++ show x ++" Y"++ show y ++" Z"++ show z interpretPolyline (start:others) = "G00 "++ gcodeXY start ++ "\n" - ++ "M62 P0 (laser on)\n" + ++ "M101 (extruder forward!)\n" ++ concat (map (\p -> "G01 " ++ (gcodeXY p) ++ "\n") others) - ++ "M63 P0 (laser off)\n\n" + ++ "M103 (extruder off)\n\n" text = gcodeHeader ++ (concat $ map interpretPolyline multilines) ++ gcodeFooter in do writeFile name text - - -writeSTL :: - ℝ3 -- ^ Lower corner of (3D) bounding box - -> ℝ3 -- ^ Upper corner of bounding box - -> ℝ -- ^ resolution of rendering - -> FilePath -- ^ Name of file to write STL to - -> Obj3 -- ^ 3D object to make STL for - -> IO() -- ^ Resulting IO action that will write STL -writeSTL (x1,y1,z1) (x2,y2,z2) d name obj = - let - grid3d = [((obj(x,y,z), obj(x+d,y,z), obj(x,y+d,z), obj(x+d,y+d,z), obj(x,y,z+d), obj(x+d,y,z+d), obj(x,y+d,z+d), obj(x+d,y+d,z+d)), (x,y,z), d )| x <- [x1, x1+d.. x2], y <- [y1, y1 +d.. y2], z <- [z1, z1+d.. z2] ] - triangles = concat $ map getTriangles grid3d - stlHeader = "solid ImplictCADExport\n" - stlFooter = "endsolid ImplictCADExport\n" - vertex :: ℝ3 -> String - vertex (x,y,z) = "vertex " ++ show x ++ " " ++ show y ++ " " ++ show z - stlTriangle :: (ℝ3, ℝ3, ℝ3) -> String - stlTriangle (a,b,c) = - "facet normal 0 0 0\n" - ++ "outer loop\n" - ++ vertex a ++ "\n" - ++ vertex b ++ "\n" - ++ vertex c ++ "\n" - ++ "endloop\n" - ++ "endfacet\n" - text = stlHeader - ++ (concat $ map stlTriangle triangles) - ++ stlFooter - in do - writeFile name text - +-} +-} diff --git a/Graphics/Implicit/Export/BoxedObj2.hs b/Graphics/Implicit/Export/BoxedObj2.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/BoxedObj2.hs @@ -0,0 +1,14 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Export.BoxedObj2 where + +import Graphics.Implicit.Definitions + +import Graphics.Implicit.Export.Definitions +import Graphics.Implicit.Export.MarchingSquares + +instance DiscreteAproxable BoxedObj2 [Polyline] where + discreteAprox res (obj,(a,b)) = getContour a b (res,res) obj diff --git a/Graphics/Implicit/Export/BoxedObj3.hs b/Graphics/Implicit/Export/BoxedObj3.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/BoxedObj3.hs @@ -0,0 +1,12 @@ + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Export.BoxedObj3 where + +import Graphics.Implicit.Definitions + +import Graphics.Implicit.Export.Definitions +import Graphics.Implicit.Export.MarchingCubes + +instance DiscreteAproxable BoxedObj3 TriangleMesh where + discreteAprox res (obj,(a,b)) = getMesh a b res obj diff --git a/Graphics/Implicit/Export/Definitions.hs b/Graphics/Implicit/Export/Definitions.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/Definitions.hs @@ -0,0 +1,14 @@ + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Export.Definitions where + +import Graphics.Implicit.Definitions + +-- | There is a discrete way to aproximate this object. +-- eg. Aproximating a 3D object with a tirangle mesh +-- would be DiscreteApproxable Obj3 TriangleMesh +class DiscreteAproxable obj aprox | obj -> aprox where + discreteAprox :: ℝ -> obj -> aprox + + diff --git a/Graphics/Implicit/Export/MarchingCubes.hs b/Graphics/Implicit/Export/MarchingCubes.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/MarchingCubes.hs @@ -0,0 +1,510 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +module Graphics.Implicit.Export.MarchingCubes (getMesh, getMesh2) where + +import Graphics.Implicit.Definitions +import Control.Parallel (par, pseq) + +-- | getMesh gets a triangle mesh describe the boundary of your 3D +-- object. +-- There are many getMesh functions in this file. THis one is the +-- simplest and should be least bug prone. Use it for debugging. +getMesh :: ℝ3 -> ℝ3 -> ℝ -> Obj3 -> TriangleMesh +getMesh (x1, y1, z1) (x2, y2, z2) res obj = + let + -- How many steps will we take on each axis? + nx = fromIntegral $ ceiling $ (x2 - x1) / res + ny = fromIntegral $ ceiling $ (y2 - y1) / res + nz = fromIntegral $ ceiling $ (y2 - y1) / res + -- Divide it up and compute the polylines + triangles :: [TriangleMesh] + triangles = [getCubeTriangles + (x1 + (x2 - x1)*mx/nx, y1 + (y2 - y1)*my/ny, z1 + (z2 - z1)*mz/nz) + (x1 + (x2 - x1)*(mx+1)/nx, y1 + (y2 - y1)*(my+1)/ny, z1 + (z2 - z1)*(mz+1)/nz) + obj + | mx <- [0.. nx-1], my <- [0..ny-1], mz <- [0..nz-1] ] + in + concat $ triangles + + +getMesh2 (x1,y1,z1) (x2,y2,z2) res obj = + let + dx = abs $ x2 - x1 + dy = abs $ y2 - y1 + dz = abs $ z2 - z1 + d = maximum [dx, dy, dz] + ffloor = fromIntegral . floor + fceil = fromIntegral . ceiling + in + if (abs.obj) ( (x1 + x2)/2, (y1 + y2)/2, (z1 + z2)/2) > d*0.9 then [] + else + if d <= res + then getCubeTriangles (x1,y1,z1) (x1+res,y1+res,z1+res) obj + else let + xs = if dx <= res then [(x1, x2)] else [(x1,xm), (xm, x2)] + where xm = x1 + res * fceil ( ffloor (dx/res) / 2.0) + ys = if dy <= res then [(y1, y2)] else [(y1,xm), (xm, y2)] + where xm = y1 + res * fceil ( ffloor (dy/res) / 2.0) + zs = if dz <= res then [(z1, z2)] else [(z1,xm), (xm, z2)] + where xm = z1 + res * fceil ( ffloor (dz/res) / 2.0) + partitions = [getMesh (x1', y1', z1') (x2', y2', z2') res obj + | (x1',x2') <- xs, (y1', y2') <- ys, (z1',z2') <- zs ] + in + concat partitions + + +getMesh3 (x1,y1,z1) (x2,y2,z2) res obj = + let + dx = abs $ x2 - x1 + dy = abs $ y2 - y1 + dz = abs $ z2 - z1 + d = maximum [dx, dy, dz] + ffloor = fromIntegral . floor + fceil = fromIntegral . ceiling + in + if (abs.obj) ( (x1 + x2)/2, (y1 + y2)/2, (z1 + z2)/2) > d*0.9 then [] + else + if d <= res + then getCubeTriangles (x1,y1,z1) (x1+res,y1+res,z1+res) obj + else let + xs = if dx <= res then [(x1, x2)] else [(x1,xm), (xm, x2)] + where xm = x1 + res * fceil ( ffloor (dx/res) / 2.0) + ys = if dy <= res then [(y1, y2)] else [(y1,xm), (xm, y2)] + where xm = y1 + res * fceil ( ffloor (dy/res) / 2.0) + zs = if dz <= res then [(z1, z2)] else [(z1,xm), (xm, z2)] + where xm = z1 + res * fceil ( ffloor (dz/res) / 2.0) + partitions = [getMesh (x1', y1', z1') (x2', y2', z2') res obj + | (x1',x2') <- xs, (y1', y2') <- ys, (z1',z2') <- zs ] + in + foldr1 par partitions `pseq` concat partitions + + + +-- | This monstrosity of a function gives triangles to divde negative interior +-- regions and positive exterior ones inside a cube, based on its vertices. +-- It is based on the linearly-interpolated marching cubes algorithm. + +getCubeTriangles :: ℝ3 -> ℝ3 -> Obj3 -> [Triangle] +getCubeTriangles (x1, y1, z1) (x2, y2, z2) obj = + let + (x,y,z) = (x1, y1, z1) + + x1y1z1 = obj (x1, y1, z1) + x2y1z1 = obj (x2, y1, z1) + x1y2z1 = obj (x1, y2, z1) + x2y2z1 = obj (x2, y2, z1) + x1y1z2 = obj (x1, y1, z2) + x2y1z2 = obj (x2, y1, z2) + x1y2z2 = obj (x1, y2, z2) + x2y2z2 = obj (x2, y2, z2) + + dx = x2 - x1 + dy = y2 - y1 + dz = z2 - z1 + + --{- Linearly interpolated + x1y1 = (x, y, z+dz*x1y1z1/(x1y1z1-x1y1z2)) + x1y2 = (x, y+dy, z+dz*x1y2z1/(x1y2z1-x1y2z2)) + x2y1 = (x+dx, y, z+dz*x2y1z1/(x2y1z1-x2y1z2)) + x2y2 = (x+dx, y+dy, z+dz*x2y2z1/(x2y2z1-x2y2z2)) + + x1z1 = (x, y+dy*x1y1z1/(x1y1z1-x1y2z1), z) + x1z2 = (x, y+dy*x1y1z2/(x1y1z2-x1y2z2), z+dz) + x2z1 = (x+dx, y+dy*x2y1z1/(x2y1z1-x2y2z1), z) + x2z2 = (x+dx, y+dy*x2y1z2/(x2y1z2-x2y2z2), z+dz) + + y1z1 = (x+dx*x1y1z1/(x1y1z1-x2y1z1), y, z) + y1z2 = (x+dx*x1y1z2/(x1y1z2-x2y1z2), y, z+dz) + y2z1 = (x+dx*x1y2z1/(x1y2z1-x2y2z1), y+dy, z) + y2z2 = (x+dx*x1y2z2/(x1y2z2-x2y2z2), y+dy, z+dz) + --} + + + {- Non-linearly interpolated + x1y1 = (x, y, z+dz/2) + x1y2 = (x, y+dy, z+dz/2) + x2y1 = (x+dx, y, z+dz/2) + x2y2 = (x+dx, y+dy, z+dz/2) + + x1z1 = (x, y+dy/2, z) + x1z2 = (x, y+dy/2, z+dz) + x2z1 = (x+dx, y+dy/2, z) + x2z2 = (x+dx, y+dy/2, z+dz) + + y1z1 = (x+dx/2, y, z) + y1z2 = (x+dx/2, y, z+dz) + y2z1 = (x+dx/2, y+dy,z) + y2z2 = (x+dx/2, y+dy,z+dz) + --} + + -- Convenience function + square a b c d = [(a,b,c),(d,a,c)] + in case + -- whether the vertices are "in" or "out" form the topological + -- basis of our triangles constructions. We must consider every + -- possible case. + + -- We arrange the vertices in a human readable way + + -- BOTTOM LAYER TOP LAYER + (x1y2z1<=0, x2y2z1<=0, x1y2z2<=0, x2y2z2<=0, + x1y1z1<=0, x2y1z1<=0, x1y1z2<=0, x2y1z2<=0) + of + + -- There are 256 cases to implement. + -- Only about half are, but they're the most common ones. + -- In practice, this has no issues redering reasonable objects. + + -- Yes, there's some symetries that could reduce the amount of code... + -- But I don't think they're worth exploiting... + -- In particular, since we're not implementing any case, + -- it would make catching the ones we don't implement... problematic. + + -- Uniform cases = empty + (False,False, False,False, + False,False, False,False) -> [] + + (True, True, True, True, + True, True, True, True ) -> [] + + -- 2 uniform layers + + (True, True, False,False, + True, True, False,False) -> square x1y1 x2y1 x2y2 x1y2 + + (False,False, True, True, + False,False, True, True ) -> square x1y1 x2y1 x2y2 x1y2 + + (True, True, True, True, + False,False, False,False) -> square x1z1 x2z1 x2z2 x1z2 + + (False,False, False,False, + True, True, True, True ) -> square x1z1 x2z1 x2z2 x1z2 + + (False,True, False,True, + False,True, False,True ) -> square y1z1 y2z1 y2z2 y1z2 + + (True, False, True, False, + True, False, True, False) -> square y1z1 y2z1 y2z2 y1z2 + + + -- z single column + + (True, False, True, False, + False,False, False,False) -> square x1z1 y2z1 y2z2 x1z2 + + (False,True, False,True, + False,False, False,False) -> square x2z1 y2z1 y2z2 x2z2 + + (False,False, False,False, + True, False, True, False) -> square x1z1 y1z1 y1z2 x1z2 + + (False,False, False,False, + False,True, False,True ) -> square y1z1 x2z1 x2z2 y1z2 + + (False,True, False,True, + True, True, True, True ) -> square x1z1 y2z1 y2z2 x1z2 + + (True, False, True, False, + True, True, True, True ) -> square x2z1 y2z1 y2z2 x2z2 + + (True, True, True, True, + False,True, False,True ) -> square x1z1 y1z1 y1z2 x1z2 + + (True, True, True, True, + True, False, True, False) -> square y1z1 x2z1 x2z2 y1z2 + + -- single y column + + (True, False, False,False, + True, False, False,False) -> square x1y1 y1z1 y2z1 x1y2 + + (False,True, False,False, + False,True, False,False) -> square x2y1 y1z1 y2z1 x2y2 + + (False,False, True, False, + False,False, True, False) -> square x1y1 y1z2 y2z2 x1y2 + + (False,False, False,True, + False,False, False,True ) -> square x2y1 y1z2 y2z2 x2y2 + + (False,True, True, True, + False,True, True, True) -> square x1y1 y1z1 y2z1 x1y2 + + (True, False, True, True, + True, False, True, True) -> square x2y1 y1z1 y2z1 x2y2 + + (True, True, False, True, + True, True, False, True) -> square x1y1 y1z2 y2z2 x1y2 + + (True, True, True, False, + True, True, True, False) -> square x2y1 y1z2 y2z2 x2y2 + + -- since x column + + (True, True, False,False, + False,False, False,False) -> square x1y2 x1z1 x2z1 x2y2 + + (False,False, False,False, + True, True, False,False) -> square x1y1 x1z1 x2z1 x2y1 + + (False,False, True, True, + False,False, False,False) -> square x1y2 x1z2 x2z2 x2y2 + + (False,False, False,False, + False,False, True, True ) -> square x1y1 x1z2 x2z2 x2y1 + + (False,False, True, True, + True, True, True, True ) -> square x1y2 x1z1 x2z1 x2y2 + + (True, True, True, True, + False,False, True, True ) -> square x1y1 x1z1 x2z1 x2y1 + + (True, True, False,False, + True, True, True, True ) -> square x1y2 x1z2 x2z2 x2y2 + + (True, True, True, True, + True, True, False,False) -> square x1y1 x1z2 x2z2 x2y1 + + -- lone points + + (True, False, False,False, + False,False, False,False) -> [(x1z1, y2z1, x1y2)] + + (False,True, False,False, + False,False, False,False) -> [(x2z1, y2z1, x2y2)] + + (False,False, False,False, + True, False, False,False) -> [(x1z1, y1z1, x1y1)] + + (False,False, False,False, + False,True, False,False) -> [(x2z1, y1z1, x2y1)] + + (False,False, True, False, + False,False, False,False) -> [(x1z2, y2z2, x1y2)] + + (False,False, False,True, + False,False, False,False) -> [(x2z2, y2z2, x2y2)] + + (False,False, False,False, + False,False, True, False) -> [(x1z2, y1z2, x1y1)] + + (False,False, False,False, + False,False, False,True ) -> [(x2z2, y1z2, x2y1)] + + (False,True, True, True, + True, True, True, True ) -> [(x1z1, y2z1, x1y2)] + + (True, False, True, True, + True, True, True, True ) -> [(x2z1, y2z1, x2y2)] + + (True, True, True, True, + False,True, True, True ) -> [(x1z1, y1z1, x1y1)] + + (True, True, True, True, + True, False, True, True ) -> [(x2z1, y1z1, x2y1)] + + (True, True, False,True, + True, True, True, True ) -> [(x1z2, y2z2, x1y2)] + + (True, True, True, False, + True, True, True, True ) -> [(x2z2, y2z2, x2y2)] + + (True, True, True, True, + True, True, False,True ) -> [(x1z2, y1z2, x1y1)] + + (True, True, True, True, + True, True, True, False) -> [(x2z2, y1z2, x2y1)] + + -- z flat + 1 + + (False,False, True, False, + False,False, True, True) -> [(x1y1,x2y1,x2z2), (x1y1,x2z2,y2z2), (x1y1,y2z2,x1y2)] + + (True, True, False,True, + True, True, False,False) -> [(x1y1,x2y1,x2z2), (x1y1,x2z2,y2z2), (x1y1,y2z2,x1y2)] + + (False,False, False,True, + False,False, True, True) -> [(x2y1,x1y1,x1z2), (x2y1,x1z2,y2z2), (x2y1,y2z2,x2y2)] + + (True, True, True, False, + True, True, False,False) -> [(x2y1,x1y1,x1z2), (x2y1,x1z2,y2z2), (x2y1,y2z2,x2y2)] + + (False,False, True, True, + False,False, True, False) -> [(x1y2,x2y2,x2z2), (x1y2,x2z2,y1z2), (x1y2,y1z2,x1y1)] + + (True, True, False,False, + True, True, False,True ) -> [(x1y2,x2y2,x2z2), (x1y2,x2z2,y1z2), (x1y2,y1z2,x1y1)] + + (False,False, True, True, + False,False, False,True) -> [(x2y2,x1y2,x1z2), (x2y2,x1z2,y1z2), (x2y2,y1z2,x2y1)] + + (True, True, False,False, + True, True, True, False) -> [(x2y2,x1y2,x1z2), (x2y2,x1z2,y1z2), (x2y2,y1z2,x2y1)] + + + + (True, False, False,False, + True, True, False,False) -> [(x1y1,x2y1,x2z1), (x1y1,x2z1,y2z1), (x1y1,y2z1,x1y2)] + + (False,True, True, True, + False,False, True, True) -> [(x1y1,x2y1,x2z1), (x1y1,x2z1,y2z1), (x1y1,y2z1,x1y2)] + + (False,True, False,False, + True, True, False,False) -> [(x2y1,x1y1,x1z1), (x2y1,x1z1,y2z1), (x2y1,y2z1,x2y2)] + + (True, False, True, True, + False,False, True, True) -> [(x2y1,x1y1,x1z1), (x2y1,x1z1,y2z1), (x2y1,y2z1,x2y2)] + + (True, True, False,False, + True, False, False,False) -> [(x1y2,x2y2,x2z1), (x1y2,x2z1,y1z1), (x1y2,y1z1,x1y1)] + + (False,False, True, True, + False,True, True, True) -> [(x1y2,x2y2,x2z1), (x1y2,x2z1,y1z1), (x1y2,y1z1,x1y1)] + + (True, True, False,False, + False,True, False,False) -> [(x2y2,x1y2,x1z1), (x2y2,x1z1,y1z1), (x2y2,y1z1,x2y1)] + + (False,False, True, True, + True, False, True, True) -> [(x2y2,x1y2,x1z1), (x2y2,x1z1,y1z1), (x2y2,y1z1,x2y1)] + + -- y flat + 1 + + (True, False, True, True, + True, False, True, False) -> [(y2z1,x2y2,x2z2),(y2z1,x2z2,y1z1),(y1z1,x2z2,y1z2)] + + (False,True, False,False, + False,True, False,True ) -> [(y2z1,x2y2,x2z2),(y2z1,x2z2,y1z1),(y1z1,x2z2,y1z2)] + + (True, False, True, False, + True, False, True, True ) -> [(y1z1,x2y1,x2z2),(y1z1,x2z2,y2z1),(y2z1,x2z2,y2z2)] + + (False,True, False,True, + False,True, False,False) -> [(y1z1,x2y1,x2z2),(y1z1,x2z2,y2z1),(y2z1,x2z2,y2z2)] + + (False,True, True, True, + False,True, False,True ) -> [(y2z1,x1y2,x1z2),(y2z1,x1z2,y1z1),(y1z1,x1z2,y1z2)] + + (True, False, False,False, + True, False, True, False) -> [(y2z1,x1y2,x1z2),(y2z1,x1z2,y1z1),(y1z1,x1z2,y1z2)] + + (False,True, False,True, + False,True, True, True ) -> [(y1z1,x1y1,x1z2),(y1z1,x1z2,y2z1),(y2z1,x1z2,y2z2)] + + (True, False, True, False, + True, False, False,False) -> [(y1z1,x1y1,x1z2),(y1z1,x1z2,y2z1),(y2z1,x1z2,y2z2)] + + + + (True, True, True, False, + True, False, True, False) -> [(y2z2,x2y2,x2z1),(y2z2,x2z1,y1z2),(y1z2,x2z1,y1z1)] + + (False,False, False,True, + False,True, False,True ) -> [(y2z2,x2y2,x2z1),(y2z2,x2z1,y1z2),(y1z2,x2z1,y1z1)] + + (True, False, True, False, + True, True, True, False) -> [(y1z2,x2y1,x2z1),(y1z2,x2z1,y2z2),(y2z2,x2z1,y2z1)] + + (False,True, False,True, + False,False, False,True) -> [(y1z2,x2y1,x2z1),(y1z2,x2z1,y2z2),(y2z2,x2z1,y2z1)] + + (True, True, False,True, + False,True, False,True) -> [(y2z2,x1y2,x1z1),(y2z2,x1z1,y1z2),(y1z2,x1z1,y1z1)] + + (False,False, True, False, + True, False, True, False) -> [(y2z2,x1y2,x1z1),(y2z2,x1z1,y1z2),(y1z2,x1z1,y1z1)] + + (False,True, False,True, + True, True, False,True) -> [(y1z2,x1y1,x1z1),(y1z2,x1z1,y2z2),(y2z2,x1z1,y2z1)] + + (True, False, True, False, + False,False, True, False) -> [(y1z2,x1y1,x1z1),(y1z2,x1z1,y2z2),(y2z2,x1z1,y2z1)] + + + + -- x flat +1 + + (True, True, True, True, + False,False, True, False) -> [(x1z1,x2z1,x1y1),(x1y1,x2z1,x2z2),(x1y1,x2z2,y1z2)] + + (False,False, False,False, + True, True, False,True ) -> [(x1z1,x2z1,x1y1),(x1y1,x2z1,x2z2),(x1y1,x2z2,y1z2)] + + (False,False, True, False, + True, True, True, True) -> [(x1z1,x2z1,x1y2),(x1y2,x2z1,x2z2),(x1y2,x2z2,y2z2)] + + (True, True, False,True, + False,False, False,False) -> [(x1z1,x2z1,x1y2),(x1y2,x2z1,x2z2),(x1y2,x2z2,y2z2)] + + (True, True, True, True, + False,False, False,True) -> [(x2z1,x1z1,x2y1),(x2y1,x1z1,x1z2),(x2y1,x1z2,y1z2)] + + (False,False, False,False, + True, True, True, False) -> [(x2z1,x1z1,x2y1),(x2y1,x1z1,x1z2),(x2y1,x1z2,y1z2)] + + (False,False, False,True, + True, True, True, True) -> [(x2z1,x1z1,x2y2),(x2y2,x1z1,x1z2),(x2y2,x1z2,y2z2)] + + (True, True, True, False, + False,False, False,False) -> [(x2z1,x1z1,x2y2),(x2y2,x1z1,x1z2),(x2y2,x1z2,y2z2)] + + + (True, True, True, True, + True, False, False,False) -> [(x1z2,x2z2,x1y1),(x1y1,x2z2,x2z1),(x1y1,x2z1,y1z1)] + + (False,False, False,False, + False,True, True, True ) -> [(x1z2,x2z2,x1y1),(x1y1,x2z2,x2z1),(x1y1,x2z1,y1z1)] + + (True, False, False,False, + True, True, True, True ) -> [(x1z2,x2z2,x1y2),(x1y2,x2z2,x2z1),(x1y2,x2z1,y2z1)] + + (False,True, True, True, + False,False, False,False) -> [(x1z2,x2z2,x1y2),(x1y2,x2z2,x2z1),(x1y2,x2z1,y2z1)] + + (True, True, True, True, + False,True, False,False) -> [(x2z2,x1z2,x2y1),(x2y1,x1z2,x1z1),(x2y1,x1z1,y1z1)] + + (False,False, False,False, + True, False, True, True) -> [(x2z2,x1z2,x2y1),(x2y1,x1z2,x1z1),(x2y1,x1z1,y1z1)] + + (False,True, False,False, + True, True, True, True) -> [(x2z2,x1z2,x2y2),(x2y2,x1z2,x1z1),(x2y2,x1z1,y2z1)] + + (True, False, True, True, + False,False, False,False) -> [(x2z2,x1z2,x2y2),(x2y2,x1z2,x1z1),(x2y2,x1z1,y2z1)] + + + + (True, True, True, False, + True, False, False,False) -> [(x1y1,x1z2,y1z1),(y1z1,x1z2,y2z2),(y1z1,y2z2,x2z1),(x2z1,y2z2,x2y2)] + + (False,False, False,True, + False,True, True, True ) -> [(x1y1,x1z2,y1z1),(y1z1,x1z2,y2z2),(y1z1,y2z2,x2z1),(x2z1,y2z2,x2y2)] + + (True, True, False,True, + False,True, False,False) -> [(x2y1,x2z2,y1z1),(y1z1,x2z2,y2z2),(y1z1,y2z2,x1z1),(x1z1,y2z2,x1y2)] + + (False,False, True, False, + True, False, True, True ) -> [(x2y1,x2z2,y1z1),(y1z1,x2z2,y2z2),(y1z1,y2z2,x1z1),(x1z1,y2z2,x1y2)] + + + + + (True, False, False,False, + True, True, True, False) -> [(x1y2,x1z2,y2z1),(y2z1,x1z2,y1z2),(y2z1,y1z2,x2z1),(x2z1,y1z2,x2y1)] + + (False,True, True, True, + False,False, False,True ) -> [(x1y2,x1z2,y2z1),(y2z1,x1z2,y1z2),(y2z1,y1z2,x2z1),(x2z1,y1z2,x2y1)] + + (False,True, False,False, + True, True, False,True ) -> [(x2y2,x2z2,y2z1),(y2z1,x2z2,y1z2),(y2z1,y1z2,x1z1),(x1z1,y1z2,x1y1)] + + (True, False, True, True, + False,False, True, False) -> [(x2y2,x2z2,y2z1),(y2z1,x2z2,y1z2),(y2z1,y1z2,x1z1),(x1z1,y1z2,x1y1)] + + + + + _ -> [] + diff --git a/Graphics/Implicit/Export/MarchingSquares.hs b/Graphics/Implicit/Export/MarchingSquares.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/MarchingSquares.hs @@ -0,0 +1,179 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +module Graphics.Implicit.Export.MarchingSquares (getContour) where + +import Graphics.Implicit.Definitions +import Control.Parallel (par, pseq) + +-- | getContour gets a polyline describe the edge of your 2D +-- object. It's really the only function in this file you need +-- to care about from an external perspective. + +getContour :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [Polyline] +getContour (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 + linesOnGrid :: [[[Polyline]]] + linesOnGrid = [[getSquareLineSegs + (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] ] + -- Cleanup, cleanup, everybody cleanup! + -- (We connect multilines, delete redundant vertices on them, etc) + multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLinesP $ linesOnGrid + in + multilines + + +-- | This function gives line segmensts to divde negative interior +-- regions and positive exterior ones inside a square, based on its +-- values at its vertices. +-- It is based on the linearly-interpolated marching squares algorithm. + +getSquareLineSegs :: ℝ2 -> ℝ2 -> Obj2 -> [Polyline] +getSquareLineSegs (x1, y1) (x2, y2) obj = + 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) + + dx = x2 - x1 + dy = y2 - y1 + + -- 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]] + + + +-- $ Functions for cleaning up the polylines +-- Many have multiple implementations as efficiency experiments. +-- At some point, we'll get rid of the redundant ones.... + + +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 + +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) +reducePolyline ((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 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') + + +polylineNotNull (a:l) = not (null l) +polylineNotNull [] = False + diff --git a/Graphics/Implicit/Export/MarchingSquaresFill.hs b/Graphics/Implicit/Export/MarchingSquaresFill.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/MarchingSquaresFill.hs @@ -0,0 +1,117 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +module Graphics.Implicit.Export.MarchingSquaresFill (getContourMesh) where + +import Graphics.Implicit.Definitions +import Control.Parallel (par, pseq) + +-- | getContour gets a polyline describe the edge of your 2D +-- object. It's really the only function in this file you need +-- to care about from an external perspective. + +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 + + +-- | This function gives line segmensts to divde negative interior +-- regions and positive exterior ones inside a square, based on its +-- values at its vertices. +-- It is based on the linearly-interpolated marching squares algorithm. + +getSquareTriangles :: ℝ2 -> ℝ2 -> Obj2 -> [(ℝ2,ℝ2,ℝ2)] +getSquareTriangles (x1, y1) (x2, y2) obj = + 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) + + dx = x2 - x1 + dy = y2 - y1 + + -- 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) + + 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]] + + + diff --git a/Graphics/Implicit/Export/PolylineFormats.hs b/Graphics/Implicit/Export/PolylineFormats.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/PolylineFormats.hs @@ -0,0 +1,49 @@ + +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +module Graphics.Implicit.Export.PolylineFormats where + +import Graphics.Implicit.Definitions + +svg polylines = text + where + -- SVG is stupidly laid out... (0,0) is the top left corner + (xs, ys) = unzip (concat polylines) + (minx, maxy) = (minimum xs, maximum ys) + transform (x,y) = (x-minx, maxy - y) + polylines2 = map (map transform) polylines + svglines = concat $ map (\line -> + " " " ++ show x ++ "," ++ show y) line) + ++ "\" style=\"stroke:rgb(0,0,255);stroke-width:1;fill:none;\"/> \n" ) + polylines2 + text = " \n" + ++ svglines + ++ " " + +hacklabLaserGCode polylines = text + where + gcodeHeader = + "(generated by ImplicitCAD, based of hacklab wiki example)\n" + ++"M63 P0 (laser off)\n" + ++"G0 Z0.002 (laser off)\n" + ++"G21 (units=mm)\n" + ++"F400 (set feedrate)\n" + ++"M3 S1 (enable laser)\n" + ++"\n" + gcodeFooter = + "M5 (disable laser)\n" + ++"G00 X0.0 Y0.0 (move to 0)\n" + ++"M2 (end)" + gcodeXY :: ℝ2 -> [Char] + gcodeXY (x,y) = "X"++ show x ++" Y"++ show y + interpretPolyline (start:others) = + "G00 "++ gcodeXY start ++ "\n" + ++ "M62 P0 (laser on)\n" + ++ concat (map (\p -> "G01 " ++ (gcodeXY p) ++ "\n") others) + ++ "M63 P0 (laser off)\n\n" + text = gcodeHeader + ++ (concat $ map interpretPolyline polylines) + ++ gcodeFooter + diff --git a/Graphics/Implicit/Export/Symbolic/CoerceSymbolic2.hs b/Graphics/Implicit/Export/Symbolic/CoerceSymbolic2.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/Symbolic/CoerceSymbolic2.hs @@ -0,0 +1,28 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Export.Symbolic.CoerceSymbolic2 (coerceSymbolic2) where + +import Graphics.Implicit.Definitions + +import Graphics.Implicit.Export.Definitions +import Graphics.Implicit.Operations +import Graphics.Implicit.Primitives + +coerceSymbolic2 :: SymbolicObj2 -> BoxedObj2 +coerceSymbolic2 (EmbedBoxedObj2 boxedObj) = boxedObj +coerceSymbolic2 (RectR r a b) = rectR r a b +coerceSymbolic2 (Circle r ) = circle r +coerceSymbolic2 (PolygonR r points) = polygonR r points +coerceSymbolic2 (UnionR2 r objs) = unionR r (map coerceSymbolic2 objs) +coerceSymbolic2 (IntersectR2 r objs) = intersectR r (map coerceSymbolic2 objs) +coerceSymbolic2 (DifferenceR2 r objs) = differenceR r (map coerceSymbolic2 objs) +coerceSymbolic2 (Complement2 obj) = complement $ coerceSymbolic2 obj +coerceSymbolic2 (Shell2 w obj) = shell w $ coerceSymbolic2 obj +coerceSymbolic2 (Translate2 v obj) = translate v $ coerceSymbolic2 obj +coerceSymbolic2 (Scale2 s obj) = scale s $ coerceSymbolic2 obj +coerceSymbolic2 (Rotate2 a obj) = rotateXY a $ coerceSymbolic2 obj +coerceSymbolic2 (Outset2 d obj) = outset 2 $ coerceSymbolic2 obj + diff --git a/Graphics/Implicit/Export/Symbolic/CoerceSymbolic3.hs b/Graphics/Implicit/Export/Symbolic/CoerceSymbolic3.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/Symbolic/CoerceSymbolic3.hs @@ -0,0 +1,33 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +-- We just want to export the instance... +module Graphics.Implicit.Export.Symbolic.CoerceSymbolic3 (coerceSymbolic3) where + +import Graphics.Implicit.Definitions +import Graphics.Implicit.Export.Definitions + +import Graphics.Implicit.Operations +import Graphics.Implicit.Primitives + +import Graphics.Implicit.Export.Symbolic.CoerceSymbolic2 + +coerceSymbolic3 :: SymbolicObj3 -> BoxedObj3 +coerceSymbolic3 (EmbedBoxedObj3 boxedObj) = boxedObj +coerceSymbolic3 (Rect3R r a b) = rect3R r a b +coerceSymbolic3 (Sphere r ) = sphere r +coerceSymbolic3 (UnionR3 r objs) = unionR r (map coerceSymbolic3 objs) +coerceSymbolic3 (IntersectR3 r objs) = intersectR r (map coerceSymbolic3 objs) +coerceSymbolic3 (DifferenceR3 r objs) = differenceR r (map coerceSymbolic3 objs) +coerceSymbolic3 (Complement3 obj) = complement $ coerceSymbolic3 obj +coerceSymbolic3 (Shell3 w obj) = shell w $ coerceSymbolic3 obj +coerceSymbolic3 (Translate3 v obj) = translate v $ coerceSymbolic3 obj +coerceSymbolic3 (Scale3 s obj) = scale s $ coerceSymbolic3 obj +coerceSymbolic3 (Outset3 d obj) = outset d $ coerceSymbolic3 obj +coerceSymbolic3 (Rotate3 rot obj) = rotate3 rot $ coerceSymbolic3 obj +coerceSymbolic3 (ExtrudeR r obj h) = extrudeR r (coerceSymbolic2 obj) h +coerceSymbolic3 (ExtrudeRMod r mod obj h) = extrudeRMod r mod (coerceSymbolic2 obj) h +coerceSymbolic3 (ExtrudeOnEdgeOf obj1 obj2) = extrudeOnEdgeOf (coerceSymbolic2 obj1) (coerceSymbolic2 obj2) + diff --git a/Graphics/Implicit/Export/Symbolic/Rebound2.hs b/Graphics/Implicit/Export/Symbolic/Rebound2.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/Symbolic/Rebound2.hs @@ -0,0 +1,12 @@ +module Graphics.Implicit.Export.Symbolic.Rebound2 (rebound2) where + +import Graphics.Implicit.Definitions +import qualified Graphics.Implicit.SaneOperators as S + +rebound2 :: BoxedObj2 -> BoxedObj2 +rebound2 (obj, (a,b)) = + let + d :: ℝ2 + d = (b S.- a) S./ (10.0 :: ℝ) + in + (obj, ((a S.- d), (b S.+ d))) diff --git a/Graphics/Implicit/Export/Symbolic/Rebound3.hs b/Graphics/Implicit/Export/Symbolic/Rebound3.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/Symbolic/Rebound3.hs @@ -0,0 +1,13 @@ +module Graphics.Implicit.Export.Symbolic.Rebound3 (rebound3) where + +import Graphics.Implicit.Definitions +import qualified Graphics.Implicit.SaneOperators as S + +rebound3 :: BoxedObj3 -> BoxedObj3 +rebound3 (obj, (a,b)) = + let + d :: ℝ3 + d = (b S.- a) S./ (10.0 :: ℝ) + in + (obj, ((a S.- d), (b S.+ d))) + diff --git a/Graphics/Implicit/Export/SymbolicObj2.hs b/Graphics/Implicit/Export/SymbolicObj2.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/SymbolicObj2.hs @@ -0,0 +1,57 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +-- This file symbolicaly renders contours and contour fillings. +-- If it can't, it passes the puck to a marching-squares-like +-- algorithm... + +module Graphics.Implicit.Export.SymbolicObj2 where + +import Graphics.Implicit.Definitions + +import Graphics.Implicit.Export.Definitions +import Graphics.Implicit.Export.MarchingSquares +import Graphics.Implicit.Export.MarchingSquaresFill +import Graphics.Implicit.Operations +import Graphics.Implicit.Primitives + +import Graphics.Implicit.Export.Symbolic.CoerceSymbolic2 +import Graphics.Implicit.Export.Symbolic.CoerceSymbolic3 +import Graphics.Implicit.Export.Symbolic.Rebound2 +import Graphics.Implicit.Export.Symbolic.Rebound3 + +import qualified Graphics.Implicit.SaneOperators as S + +instance DiscreteAproxable SymbolicObj2 [Polyline] where + discreteAprox res obj = symbolicGetContour res obj + + +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) +symbolicGetContour res (Translate2 v obj) = map (map (S.+ v) ) $ symbolicGetContour res obj +symbolicGetContour res (Scale2 s obj) = map (map (S.* s)) $ symbolicGetContour res obj +symbolicGetContour res obj = case rebound2 (coerceSymbolic2 obj) of + (obj, (a,b)) -> getContour a b (res,res) obj + + +symbolicGetContourMesh :: ℝ -> SymbolicObj2 -> [(ℝ2,ℝ2,ℝ2)] +symbolicGetContourMesh res (Translate2 v obj) = map (\(a,b,c) -> (a S.+ v, b S.+ v, c S.+ v) ) $ + symbolicGetContourMesh res obj +symbolicGetContourMesh res (Scale2 s obj) = map (\(a,b,c) -> (a S.* s, b S.* s, c S.* s) ) $ + symbolicGetContourMesh res obj +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) +symbolicGetContourMesh res obj = case rebound2 (coerceSymbolic2 obj) of + (obj, (a,b)) -> getContourMesh a b (res,res) obj + + diff --git a/Graphics/Implicit/Export/SymbolicObj3.hs b/Graphics/Implicit/Export/SymbolicObj3.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/SymbolicObj3.hs @@ -0,0 +1,188 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +-- The purpose of this function is to symbolicaly compute triangle meshes where possible. +-- Otherwise we coerce it into an implicit function and apply our modified marching cubes algorithm. + +-- We just want to export the instance... +module Graphics.Implicit.Export.SymbolicObj3 (symbolicGetMesh) where + +import Graphics.Implicit.Definitions + +import Graphics.Implicit.Export.Definitions +import Graphics.Implicit.Export.MarchingCubes + +import Graphics.Implicit.Operations +import Graphics.Implicit.Primitives + +import Graphics.Implicit.Export.SymbolicObj2 + +import qualified Graphics.Implicit.SaneOperators as S + +import Graphics.Implicit.Export.Symbolic.CoerceSymbolic2 +import Graphics.Implicit.Export.Symbolic.CoerceSymbolic3 +import Graphics.Implicit.Export.Symbolic.Rebound2 +import Graphics.Implicit.Export.Symbolic.Rebound3 +import Graphics.Implicit.Export.Util (divideMeshTo, dividePolylineTo) + + +instance DiscreteAproxable SymbolicObj3 TriangleMesh where + discreteAprox res 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 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 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)] + in + square (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) + ++ square (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) + ++ square (x2,y1,z1) (x2,y1,z2) (x2,y2,z2) (x2,y2,z1) + +-- Use spherical coordiantes to create an easy tesselation of a sphere +symbolicGetMesh res (Sphere r) = + let + square a b c d = [(a,b,c),(d,a,c)] + n = max 5 (fromIntegral $ ceiling $ 3*r/res) + in + concat [ square + (r*cos(2*pi*m1/n), r*sin(2*pi*m1/n)*cos(pi*m2/n), r*sin(2*pi*m1/n)*sin(pi*m2/n) ) + (r*cos(2*pi*(m1+1)/n), r*sin(2*pi*(m1+1)/n)*cos(pi*m2/n), r*sin(2*pi*(m1+1)/n)*sin(pi*m2/n) ) + (r*cos(2*pi*(m1+1)/n), r*sin(2*pi*(m1+1)/n)*cos(pi*(m2+1)/n), r*sin(2*pi*(m1+1)/n)*sin(pi*(m2+1)/n) ) + (r*cos(2*pi*m1/n), r*sin(2*pi*m1/n)*cos(pi*(m2+1)/n), r*sin(2*pi*m1/n)*sin(pi*(m2+1)/n)) + | m1 <- [0.. n-1], m2 <- [0.. n-1] ] + +-- We can compute a mesh of a rounded, extruded object from it contour, +-- contour filling trinagles, and magic. +-- General approach: +-- - generate sides by basically cross producting the contour. +-- - 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 = fst $ coerceSymbolic2 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 _ = [] + -- 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 $ symbolicGetContour 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 = [((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 + + +-- This is quite similar to the one above +-- Key differences are the seperation of the middle part into many layers, +-- and the final transform. +symbolicGetMesh res (ExtrudeRMod r mod obj2 h) = + let + -- Get a Obj2 (magnitude descriptor object) + obj2mag :: Obj2 -- = ℝ2 -> ℝ + obj2mag = fst $ coerceSymbolic2 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 _ = [] + -- The number of steps we're going to do the sides in: + n = fromIntegral $ ceiling $ h/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 - 2*r + 2*dh x1 y1 + mainH2 = h - 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 + mainH1*m/n + lb2 = r-dh x2 y2 + mainH1*(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 $ symbolicGetContour res obj2 + -- Create sides for the main body of our object = segs × (r,h-r) + -- Many layers... + side_tris = 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 = [((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] + -- Mesh modifiers in individual components + fx :: ℝ3 -> ℝ + fx (x,y,z) = fst $ mod z (x,y) + fy :: ℝ3 -> ℝ + fy (x,y,z) = snd $ mod z (x,y) + -- 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) + +-- 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 (coerceSymbolic3 obj) of + (obj, (a,b)) -> getMesh a b res obj + diff --git a/Graphics/Implicit/Export/TriangleMeshFormats.hs b/Graphics/Implicit/Export/TriangleMeshFormats.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/TriangleMeshFormats.hs @@ -0,0 +1,26 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +module Graphics.Implicit.Export.TriangleMeshFormats where + +import Graphics.Implicit.Definitions + +stl triangles = text + where + stlHeader = "solid ImplictCADExport\n" + stlFooter = "endsolid ImplictCADExport\n" + vertex :: ℝ3 -> String + vertex (x,y,z) = "vertex " ++ show x ++ " " ++ show y ++ " " ++ show z + stlTriangle :: (ℝ3, ℝ3, ℝ3) -> String + stlTriangle (a,b,c) = + "facet normal 0 0 0\n" + ++ "outer loop\n" + ++ vertex a ++ "\n" + ++ vertex b ++ "\n" + ++ vertex c ++ "\n" + ++ "endloop\n" + ++ "endfacet\n" + text = stlHeader + ++ (concat $ map stlTriangle triangles) + ++ stlFooter + diff --git a/Graphics/Implicit/Export/Util.hs b/Graphics/Implicit/Export/Util.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Export/Util.hs @@ -0,0 +1,76 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +-- Functions to make meshes/polylines finer. + +module Graphics.Implicit.Export.Util (divideMesh2To, divideMeshTo, dividePolylineTo) where + +-- import Prelude hiding ((+),(-),(*),(/)) +import Graphics.Implicit.Definitions +import qualified Graphics.Implicit.SaneOperators as S + +-- 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 + +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 + +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] + + + diff --git a/Graphics/Implicit/ExtOpenScad.hs b/Graphics/Implicit/ExtOpenScad.hs --- a/Graphics/Implicit/ExtOpenScad.hs +++ b/Graphics/Implicit/ExtOpenScad.hs @@ -3,191 +3,20 @@ -- We'd like to parse openscad code, with some improvements, for backwards compatability. -module Graphics.Implicit.ExtOpenScad where - -import Prelude hiding (lookup) -import Graphics.Implicit.Definitions -import Data.Map hiding (map) -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Expr -import Control.Monad (liftM) - -type VariableLookup = Map String OpenscadObj - -data OpenscadObj = OUndefined - | OBool Bool - | ONum ℝ - | OList [OpenscadObj] - | OString String - | OFunc ( OpenscadObj -> OpenscadObj ) - -instance Show OpenscadObj 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) = "" - -numericOFunc f = OFunc $ \oObj -> case oObj of - ONum n -> ONum $ f n - _ -> OUndefined - -data Computation = - ControlStructure ( VariableLookup -> [Computation] -> ([Obj2], [Obj3], VariableLookup) ) [Computation] - | Assignment (VariableLookup -> VariableLookup) - | Object2 (VariableLookup -> Obj2) - | Object3 (VariableLookup -> Obj3) - | Include String - -variableSymb = many1 (noneOf " ,|[]{}()*&^%$#@!~`'\"\\/;:.,<>?") "variable" - -variable :: GenParser Char st (VariableLookup -> OpenscadObj) -variable = liftM (\varstr -> \varlookup -> case lookup varstr varlookup of - Nothing -> OUndefined - Just a -> a ) - variableSymb - - - -literal :: GenParser Char st (VariableLookup -> OpenscadObj) -literal = - try ( (string "true" >> return (\map -> OBool True) ) - <|> (string "false" >> return (\map -> OBool False) ) - "boolean" ) - <|> try ( try (do - a <- (many1 digit); - char '.'; - b <- (many digit); - return ( \map -> ONum ( read (a ++ "." ++ b) :: ℝ) ); - ) <|> (do - a <- (many1 digit); - return ( \map -> ONum ( read a :: ℝ) ); - ) "number" ) - <|> try ( ( do - string "\""; - strlit <- many $ noneOf "\"\n"; - string "\""; - return $ \map -> OString $ strlit; - ) "string" ) - "literal" - --- space = oneOf " \t\n" - --- We represent the priority or 'fixity' of different types of expressions --- by the Int argument - -expression :: Int -> GenParser Char st (VariableLookup -> OpenscadObj) -expression 10 = (try literal) <|> (try variable ) - <|> ((do - string "("; - many space; - expr <- expression 0; - many space; - string ")"; - return expr; - ) "bracketed expression" ) - <|> ( ( do - string "["; - many space; - exprs <- sepBy (expression 0) (many space >> char ',' >> many space); - many space; - string "]"; - return $ \varlookup -> OList (map ($varlookup) exprs ) - ) "vector/list" ) -expression 9 = ( try( do - f <- expression 10; - string "("; - many space; - arg <- expression 0; - many space; - string ")"; - return $ \varlookup -> - case f varlookup of - OFunc actual_func -> actual_func (arg varlookup) - _ -> OUndefined - ) "function appliation" ) - <|> try (expression 10) -expression n@8 = try (( do - a <- expression (n+1); - string "^"; - b <- expression n; - return $ \varlookup -> case (a varlookup, b varlookup) of - (ONum na, ONum nb) -> ONum (na ** nb) - _ -> OUndefined - ) "exponentiation") - <|> try (expression $ n+1) -expression n@7 = try (expression $ n+1) -expression n@6 = - let - 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 _ _ = OUndefined - - div (ONum a) (ONum b) = ONum (a/b) - div (OList a) (ONum b) = OList (map (\x -> div x (ONum b)) a) - div _ _ = OUndefined - in try (( do - exprs <- sepBy1 (sepBy (expression $ n+1) (char '/')) (char '*') - return $ \varlookup -> foldl1 mult $ map ( (foldl1 div) . (map ($varlookup) ) ) exprs; - ) "multiplication/division") - <|>try (expression $ n+1) -expression n@5 = - let - append (OList a) (OList b) = OList $ a++b - append (OString a) (OString b) = OString $ a++b - append _ _ = OUndefined - in try (( do - exprs <- sepBy1 (expression $ n+1) (string "++") - return $ \varlookup -> foldl1 append $ map ($varlookup) exprs; - ) "append") - <|>try (expression $ n+1) - -expression n@4 = - let - add (ONum a) (ONum b) = ONum (a+b) - add (OList a) (OList b) = OList $ zipWith add a b - add _ _ = OUndefined - - sub (ONum a) (ONum b) = ONum (a-b) - sub (OList a) (OList b) = OList $ zipWith sub a b - sub _ _ = OUndefined - in try (( do - exprs <- sepBy1 (sepBy (expression $ n+1) (char '-')) (char '+') - return $ \varlookup -> foldl1 add $ map ( (foldl1 sub) . (map ($varlookup) ) ) exprs; - ) "addition/subtraction") - <|>try (expression $ n+1) -expression n@3 = try (expression $ n+1) -expression n@2 = try (expression $ n+1) -expression n@1 = try (expression $ n+1) -expression n@0 = try (expression $ n+1) - - +module Graphics.Implicit.ExtOpenScad (runOpenscad) where -testParse str = case parse (expression 0) "" str of - Right res -> show $ res - (fromList [("sin", numericOFunc sin)] ) - Left err -> show err +import Graphics.Implicit.ExtOpenScad.Default (defaultObjects) +import Graphics.Implicit.ExtOpenScad.Statements (computationStatement, runComputations) +import Text.ParserCombinators.Parsec (parse, many1) +import Control.Monad (liftM) -assigmentStatement = do - var <- variableSymb - many space - char '=' - many space - val <- expression 0 - return $ Assignment (\varlookup -> insert var (val varlookup) varlookup) +-- Small wrapper to handle parse errors, etc +runOpenscad str = case parse (many1 computationStatement) "" str of + Right res -> Right $ runComputationsDefault res + Left err -> Left err -{-ifStatement = do - string "if" - many space - char '(' - condition <- expression 0 - char ')' - many space - trueCase <- computationStatement-} - +runComputationsDefault = runComputations $ + return (defaultObjects, [], []) -computationStatement = assigmentStatement diff --git a/Graphics/Implicit/ExtOpenScad/Default.hs b/Graphics/Implicit/ExtOpenScad/Default.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/ExtOpenScad/Default.hs @@ -0,0 +1,61 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +-- We'd like to parse openscad code, with some improvements, for backwards compatability. + +module Graphics.Implicit.ExtOpenScad.Default where + +import Graphics.Implicit.Definitions +import Graphics.Implicit.ExtOpenScad.Definitions +import Data.Map (Map, fromList) + +defaultObjects :: VariableLookup -- = Map String OpenscadObj +defaultObjects = fromList $ + defaultConstants + ++ defaultFunctions + ++ defaultFunctions2 + ++ defaultFunctionsSpecial + +defaultConstants = map (\(a,b) -> (a, ONum b)) + [("pi", pi)] + +defaultFunctions = map (\(a,b) -> (a, numericOFunc b)) + [ + ("sin", sin), + ("cos", cos), + ("tan", tan), + ("abs", abs), + ("sign", signum), + ("floor", fromIntegral . floor ), + ("ceil", fromIntegral . ceiling ), + ("exp", exp) + ] + +defaultFunctions2 = map (\(a,b) -> (a, numericOFunc2 b)) + [ + ("max", max), + ("min", min) + ] + +defaultFunctionsSpecial = [("map", mapfunc)] + +-- Stupid functions for convering to openscad objects follow: + +mapfunc = OFunc $ \oObj -> case oObj of + OFunc f -> OFunc $ \oObj2 -> case oObj2 of + OList l -> OList $ map f l + _ -> OUndefined + _ -> OUndefined + +numericOFunc f = OFunc $ \oObj -> case oObj of + ONum n -> ONum $ f n + _ -> OUndefined + + +numericOFunc2 f = OFunc $ \oObj -> case oObj of + ONum n -> OFunc $ \oObj2 -> case oObj2 of + ONum n2 -> ONum $ f n n2 + _ -> OUndefined + _ -> OUndefined + + diff --git a/Graphics/Implicit/ExtOpenScad/Definitions.hs b/Graphics/Implicit/ExtOpenScad/Definitions.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/ExtOpenScad/Definitions.hs @@ -0,0 +1,48 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +-- We'd like to parse openscad code, with some improvements, for backwards compatability. + +module Graphics.Implicit.ExtOpenScad.Definitions where + +import Graphics.Implicit.Definitions +import Data.Map (Map) + +-- Lets make it easy to change the object types we're using :) + +-- | The 2D object type to be used in ExtOpenScad +type Obj2Type = SymbolicObj2 +-- | The 3D object type to be used in ExtOpenScad +type Obj3Type = SymbolicObj3 + +type VariableLookup = Map String OpenscadObj + +data OpenscadObj = OUndefined + | OBool Bool + | ONum ℝ + | OList [OpenscadObj] + | OString String + | OFunc ( OpenscadObj -> OpenscadObj ) + | OModule (ArgParser ComputationStateModifier) + +instance Show OpenscadObj 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) = "" + +data ArgParser a = ArgParser String (Maybe OpenscadObj) (OpenscadObj -> ArgParser a) + | ArgParserTerminator a + | ArgParserFail + +type ComputationState = IO (VariableLookup, [Obj2Type], [Obj3Type]) + +type ComputationStateModifier = ComputationState -> ComputationState + +coerceNum (ONum n) = n +coerceNum _ = sqrt (-1) + +coerceBool (OBool b) = b +coerceBool _ = False diff --git a/Graphics/Implicit/ExtOpenScad/Expressions.hs b/Graphics/Implicit/ExtOpenScad/Expressions.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/ExtOpenScad/Expressions.hs @@ -0,0 +1,193 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +-- We'd like to parse openscad code, with some improvements, for backwards compatability. + +module Graphics.Implicit.ExtOpenScad.Expressions where + +-- We need lookup from Data.Map +import Prelude hiding (lookup) +import Data.Map (Map, lookup) +import Graphics.Implicit.Definitions +import Graphics.Implicit.ExtOpenScad.Definitions +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr + +variableSymb = many1 (noneOf " ,|[]{}()+-*&^%#@!~`'\"\\/;:.,<>?=") "variable" + +variable :: GenParser Char st (VariableLookup -> OpenscadObj) +variable = fmap (\varstr -> \varlookup -> case lookup varstr varlookup of + Nothing -> OUndefined + Just a -> a ) + variableSymb + +literal :: GenParser Char st (VariableLookup -> OpenscadObj) +literal = + try ( (string "true" >> return (\map -> OBool True) ) + <|> (string "false" >> return (\map -> OBool False) ) + "boolean" ) + <|> try ( try (do + a <- (many1 digit); + char '.'; + b <- (many digit); + return ( \map -> ONum ( read (a ++ "." ++ b) :: ℝ) ); + ) <|> (do + a <- (many1 digit); + return ( \map -> ONum ( read a :: ℝ) ); + ) "number" ) + <|> try ( ( do + string "\""; + strlit <- many $ try (string "\\\"" >> return '\"') <|> try (string "\\n" >> return '\n') <|> ( noneOf "\"\n"); + string "\""; + return $ \map -> OString $ strlit; + ) "string" ) + "literal" + +-- We represent the priority or 'fixity' of different types of expressions +-- by the Int argument + +expression :: Int -> GenParser Char st (VariableLookup -> OpenscadObj) +expression 10 = (try literal) <|> (try variable ) + <|> ((do + string "("; + expr <- expression 0; + string ")"; + return expr; + ) "bracketed expression" ) + <|> ( try ( do + string "["; + exprs <- sepBy (expression 0) (char ',' ); + string "]"; + return $ \varlookup -> OList (map ($varlookup) exprs ) + ) <|> ( do + string "["; + exprs <- sepBy (expression 0) (char ':' ); + string "]"; + return $ \varlookup -> OList $ map ONum $ case map (coerceNum.($varlookup)) exprs of + a:[] -> [a] + a:b:[] -> [a .. b] + a:b:c:xs -> [a, a+b .. c] + ) "vector/list" ) +expression 9 = + let + -- Like in Haskell, we're going to think of functions of + -- many variables as functions that result in functions. + -- So f(a,b) = f(a)(b) :) + applyArgs :: OpenscadObj -> [OpenscadObj] -> OpenscadObj + applyArgs obj [] = obj + applyArgs (OFunc f) (arg:others) = applyArgs (f arg) others + applyArgs _ _ = OUndefined + -- List splicing, like in Python. 'Cause list splicing is + -- awesome! + splice :: [a] -> ℝ -> ℝ -> [a] + splice [] _ _ = [] + splice (x:xs) a b + | floor a < 0 = splice xs (fromIntegral $ length xs + floor a) (fromIntegral $ floor b) + | floor b < 0 = splice xs (fromIntegral $ floor a) ( fromIntegral $ length xs + floor b) + | floor a > 0 = splice xs (fromIntegral $ floor a - 1) (fromIntegral $ floor b) + | floor b > 0 = x : (splice xs (fromIntegral $ floor a) (fromIntegral $ floor b - 1 ) ) + | otherwise = [] + in ( try( do + f <- expression 10; + many space + string "("; + args <- sepBy (expression 0) (many space >> char ',' >> many space); + string ")"; + return $ \varlookup -> applyArgs (f varlookup) (map ($varlookup) args) + ) "function appliation" ) + <|> ( try( do + l <- expression 10; + string "["; + i <- expression 0; + string "]"; + return $ \varlookup -> + case (l varlookup, i varlookup) of + (OList actual_list, ONum ind) -> actual_list !! (floor ind) + (OString str, ONum ind) -> OString $ [str !! (floor ind)] + _ -> OUndefined + ) "list indexing" ) + <|> ( try( do + l <- expression 10; + string "["; + start <- (try $ expression 0) <|> (many space >> return (\_ -> OUndefined)); + char ':'; + end <- (try $ expression 0) <|> (many space >> return (\_ -> OUndefined)); + string "]"; + return $ \varlookup -> + case (l varlookup, start varlookup, end varlookup) of + (OList list, ONum a, ONum b ) -> OList $ splice list a b + (OString str, ONum a, ONum b ) -> OString $ splice str a b + (OList list, OUndefined, ONum b ) -> OList $ splice list 0 b + (OString str, OUndefined, ONum b ) -> OString $ splice str 0 b + (OList list, ONum a, OUndefined) -> OList $ splice list a (1.0/0.0) + (OString str, ONum a, OUndefined) -> OString $ splice str a (1.0/0.0) + (OList list, OUndefined, OUndefined) -> OList $ splice list 0 (1.0/0.0) + (OString str, OUndefined, OUndefined) -> OString $ splice str 0 (1.0/0.0) + _ -> OUndefined + ) "list splicing" ) + <|> try (expression 10) +expression n@8 = try (( do + a <- expression (n+1); + string "^"; + b <- expression n; + return $ \varlookup -> case (a varlookup, b varlookup) of + (ONum na, ONum nb) -> ONum (na ** nb) + _ -> OUndefined + ) "exponentiation") + <|> try (expression $ n+1) +expression n@7 = try (expression $ n+1) +expression n@6 = + let + 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 _ _ = OUndefined + + div (ONum a) (ONum b) = ONum (a/b) + div (OList a) (ONum b) = OList (map (\x -> div x (ONum b)) a) + div _ _ = OUndefined + in try (( do + exprs <- sepBy1 (sepBy1 (expression $ n+1) (char '/')) (char '*') + return $ \varlookup -> foldl1 mult $ map ( (foldl1 div) . (map ($varlookup) ) ) exprs; + ) "multiplication/division") + <|>try (expression $ n+1) +expression n@5 = + let + append (OList a) (OList b) = OList $ a++b + append (OString a) (OString b) = OString $ a++b + append _ _ = OUndefined + in try (( do + exprs <- sepBy1 (expression $ n+1) (string "++") + return $ \varlookup -> foldl1 append $ map ($varlookup) exprs; + ) "append") + <|>try (expression $ n+1) + +expression n@4 = + let + add (ONum a) (ONum b) = ONum (a+b) + add (OList a) (OList b) = OList $ zipWith add a b + add _ _ = OUndefined + + sub (ONum a) (ONum b) = ONum (a-b) + sub (OList a) (OList b) = OList $ zipWith sub a b + sub _ _ = OUndefined + in try (( do + exprs <- sepBy1 (sepBy1 (expression $ n+1) ( char '-')) (char '+') + return $ \varlookup -> foldl1 add $ map ( (foldl1 sub) . (map ($varlookup) ) ) exprs; + ) "addition/subtraction") + <|>try (expression $ n+1) +expression n@3 = + let + negate (ONum n) = ONum (-n) + negate (OList l) = OList $ map negate l + negate _ = OUndefined + in try (do + char '-' + many space + expr <- expression $ n+1 + return $ \varlookup -> negate $ expr varlookup + ) <|> try (expression $ n+1) +expression n@2 = try (expression $ n+1) +expression n@1 = try (expression $ n+1) +expression n@0 = try (do { many space; expr <- expression $ n+1; many space; return expr}) <|> try (expression $ n+1) + diff --git a/Graphics/Implicit/ExtOpenScad/Primitives.hs b/Graphics/Implicit/ExtOpenScad/Primitives.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/ExtOpenScad/Primitives.hs @@ -0,0 +1,129 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +-- We'd like to parse openscad code, with some improvements, for backwards compatability. + +-- This file provides primitive objects for the openscad parser. +-- The code is fairly straightforward; an explanation of how +-- the first one works is provided. + +-- Note: Primitives must be added to the computationStatement parser in +-- Graphics.Implicit.ExtOpenScad.Statements to have any effect!!! + +module Graphics.Implicit.ExtOpenScad.Primitives where + +import Prelude hiding (lookup) +import Graphics.Implicit.Definitions +import qualified Graphics.Implicit.Primitives as Prim +import Graphics.Implicit.ExtOpenScad.Definitions +import Graphics.Implicit.ExtOpenScad.Expressions +import Graphics.Implicit.ExtOpenScad.Util +import Data.Map (Map, lookup) +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr +import Control.Monad (liftM) + +-- **Exmaple of implementing a module** +-- sphere is a module without a suite named sphere, +-- this means that the parser will look for this like +-- sphere(args...); +sphere = moduleWithoutSuite "sphere" $ do + -- What are the arguments? + -- The radius, r, which is a (real) number. + -- If we didn't specify real, we'd get an openscadObj + -- but we use the real convenience function. + -- Because we don't provide a default, this ends right + -- here if it doesn't get a suitable argument! + r <- realArgument "r"; + -- 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 + size <- argument "size"; + center <- boolArgumentWithDefault "center" False; + r <- realArgumentWithDefault "r" 0; + case size of + OList ((ONum x):(ONum y):(ONum z):[]) -> + if center + then addObj3 $ Prim.rect3R r (-x/2, -y/2, -z/2) (x/2, y/2, z/2) + else addObj3 $ Prim.rect3R r (0,0,0) (x,y,z) + ONum w -> + if center + then addObj3 $ Prim.rect3R r (-w/2,-w/2,-w/2) (w/2,w/2,w/2) + else addObj3 $ Prim.rect3R r (0,0,0) (w,w,w) + _ -> noChange; + +-- What about $fn for regular n-gon prisms? This will break models.. +cylinder = moduleWithoutSuite "cylinder" $ do + h <- realArgumentWithDefault "h" 1; + r <- realArgumentWithDefault "r" 1; + r1 <- realArgumentWithDefault "r1" 1; + r2 <- realArgumentWithDefault "r2" 1; + center <- boolArgumentWithDefault "center" False; + if r1 == 1 && r2 == 1 + then if center + then addObj3 $ Prim.cylinderC r h + else addObj3 $ Prim.cylinder r h + else if center + then addObj3 $ Prim.cylinder2C r1 r2 h + else addObj3 $ Prim.cylinder2 r1 r2 h + + +circle = moduleWithoutSuite "circle" $ do + r <- realArgument "r"; + fn <- intArgumentWithDefault "$fn" (-1); + if fn < 3 + then addObj2 $ Prim.circle r + else addObj2 $ Prim.polygonR 0 [(r*cos θ, r*sin θ )| θ <- [2*pi*n/fromIntegral fn | n <- [0.0 .. fromIntegral fn - 1.0]]] + --else addObj2 $ Prim.regularPolygon fn r + +square = moduleWithoutSuite "square" $ do + size <- argument "size"; + center <- boolArgumentWithDefault "center" False; + r <- realArgumentWithDefault "r" 0; + case size of + OList ((ONum x):(ONum y):[]) -> + if center + then addObj2 $ Prim.rectR r (-x/2, -y/2) (x/2, y/2) + else addObj2 $ Prim.rectR r (0,0) (x, y) + ONum w -> + if center + then addObj2 $ Prim.rectR r (-w/2, -w/2) (w/2, w/2) + else addObj2 $ Prim.rectR r (0,0) (w,w) + _ -> noChange; + + +polygon = moduleWithoutSuite "polygon" $ do + points <- argument "points"; + pathes <- argumentWithDefault "pathes" (OUndefined); + let + extractTupleList :: [OpenscadObj] -> Maybe [ℝ2] + extractTupleList [] = Just [] + extractTupleList (OList ((ONum x):(ONum y):[]):others) = + case extractTupleList others of + Just l -> Just $ (x,y):l + Nothing -> Nothing + extractTupleList _ = Nothing + + extractNumList :: [OpenscadObj] -> Maybe [ℝ] + extractNumList [] = Just [] + extractNumList ((ONum n):others) = + case extractNumList others of + Just l -> Just $ n:l + Nothing -> Nothing + extractNumList _ = Nothing + + in case (points, pathes) of + (OList pointList, OUndefined) -> case extractTupleList pointList of + Just tupleList -> addObj2 $ Prim.polygonR 0 tupleList + Nothing -> noChange + {-(OList pointList, OList pathList) -> + case (extractTupleList pointList, extractNumList pathList) of + (Just l1, Just l2) -> -} + _ -> noChange; + + + diff --git a/Graphics/Implicit/ExtOpenScad/Statements.hs b/Graphics/Implicit/ExtOpenScad/Statements.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/ExtOpenScad/Statements.hs @@ -0,0 +1,411 @@ + + +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +-- We'd like to parse openscad code, with some improvements, for backwards compatability. + +-- Implement statements for things other than primitive objects! + +module Graphics.Implicit.ExtOpenScad.Statements where + +import Prelude hiding (lookup) +import Graphics.Implicit.Definitions +import Graphics.Implicit.ExtOpenScad.Definitions +import Graphics.Implicit.ExtOpenScad.Expressions +import Graphics.Implicit.ExtOpenScad.Util +import Graphics.Implicit.ExtOpenScad.Primitives +import qualified Graphics.Implicit.Operations as Op +import Data.Map (Map, lookup, insert) +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr +import Control.Monad (liftM) + +tryMany = (foldl1 (<|>)) . (map try) + +-- | A statement in our programming openscad-like programming language. +computationStatement :: GenParser Char st ComputationStateModifier +computationStatement = + (try $ do -- suite statemetns: no semicolon... + many space + s <- tryMany [ + ifStatement, + forStatement, + unionStatement, + intersectStatement, + differenceStatement, + translateStatement, + rotateStatement, + scaleStatement, + extrudeStatement, + shellStatement + -- rotateExtrudeStatement + ] + many space + return s + ) <|> (try $ do -- Non suite statements. Semicolon needed... + many space + s <- tryMany [ + echoStatement, + assigmentStatement, + includeStatement, + useStatement, + sphere, + cube, + square, + cylinder, + circle, + polygon + ] + many space + char ';' + many space + return s + )<|> (many space >> comment) + + + +-- | A suite of statements! +-- What's a suite? Consider: +-- +-- union() { +-- sphere(3); +-- } +-- +-- The suite was in the braces ({}). Similarily, the +-- following has the same suite: +-- +-- union() sphere(3); +-- +-- We consider it to be a list of statements which +-- are in tern ComputationStateModifier s. +-- So this parses them. + +suite :: GenParser Char st [ComputationStateModifier] +suite = (liftM return computationStatement <|> do + char '{' + many space + stmts <- many (try computationStatement) + many space + char '}' + return stmts + ) "statement suite" + +-- | Run a list of computations! +-- We start with a state and run it through a bunch of ComputationStateModifier s. +runComputations :: ComputationState -> [ComputationStateModifier] -> ComputationState +runComputations = foldl (\a b -> b $ a) + +-- | We think of comments as statements that do nothing. It's just convenient. +comment = + (((try $ do + string "//" + many ( noneOf "\n") + string "\n" + ) <|> (do + string "/*" + manyTill anyChar (try $ string "*/") + )) >> return id) "comment" + +-- An included statement! Basically, inject another openscad file here... +includeStatement :: GenParser Char st ComputationStateModifier +includeStatement = (do + string "include" + many space + string "<" + filename <- many (noneOf "<>") + string ">" + return $ \ ioWrappedState -> do + state@(varlookup,obj2s,obj3s) <- ioWrappedState; + content <- readFile filename + case parse (many1 computationStatement) "" content of + Left err -> do + putStrLn $ "Error parsing included file " ++ filename + putStrLn $ show err + putStrLn $ "Ignoring included file " ++ filename ++ "..." + return state + Right result -> runComputations (return state) result + ) "include statement" + +-- In a use statement, variables are imported but we drop any existing 2D/3D objects. +useStatement :: GenParser Char st ComputationStateModifier +useStatement = (do + string "use" + many space + string "<" + filename <- many (noneOf "<>") + string ">" + return $ \ ioWrappedState -> do + state@(varlookup, _, _) <- ioWrappedState; + content <- readFile filename + case parse (many1 computationStatement) "" content of + Left err -> do + putStrLn $ "Error parsing used file " ++ filename + putStrLn $ show err + putStrLn $ "Ignoring used file " ++ filename ++ "..." + return state + Right result -> runComputations (return (varlookup,[],[])) result + ) "use statement" + + +-- | An assignment statement (parser) +assigmentStatement :: GenParser Char st ComputationStateModifier +assigmentStatement = + (try $ do + varSymb <- variableSymb + many space + char '=' + many space + valExpr <- expression 0 + return $ \ ioWrappedState -> do + (varlookup, obj2s, obj3s) <- ioWrappedState + let + val = valExpr varlookup + return (insert varSymb val varlookup, obj2s, obj3s) + ) <|> (try $ do + varSymb <- variableSymb + many space + char '(' + many space + argVars <- sepBy variableSymb (many space >> char ',' >> many space) + many space + char ')' + many space + char '=' + many space + valExpr <- expression 0 + return $ \ ioWrappedState -> do + (varlookup, obj2s, obj3s) <- ioWrappedState + let + makeFunc baseExpr (argVar:xs) varlookup' = OFunc $ + \argObj -> makeFunc baseExpr xs (insert argVar argObj varlookup') + makeFunc baseExpr [] varlookup' = baseExpr varlookup' + val = makeFunc valExpr argVars varlookup + return (insert varSymb val varlookup, obj2s, obj3s) + ) "assignment statement" + +-- | An echo statement (parser) +echoStatement :: GenParser Char st ComputationStateModifier +echoStatement = do + string "echo" + many space + char '(' + many space + val <- expression 0 + many space + char ')' + return $ \ ioWrappedState -> do + state@(varlookup, _, _) <- ioWrappedState + putStrLn $ show $ val varlookup + return state + +ifStatement = (do + string "if" + many space + char '(' + bexpr <- expression 0 + char ')' + many space + statementsTrueCase <- suite + many space + statementsFalseCase <- try (string "else" >> many space >> suite ) <|> (return []) + return $ \ ioWrappedState -> do + state@(varlookup, _, _) <- ioWrappedState + if case bexpr varlookup of + OBool b -> b + _ -> False + then runComputations (return state) statementsTrueCase + else runComputations (return state) statementsFalseCase + ) "if statement" + +forStatement = (do + -- a for loop is of the form: + -- for ( vsymb = vexpr ) loopStatements + -- eg. for ( a = [1,2,3] ) {echo(a); echo "lol";} + string "for" + many space + char '(' + many space + vsymb <- variableSymb + many space + char '=' + vexpr <- expression 0 + char ')' + many space + loopStatements <- suite + return $ \ ioWrappedState -> do + -- a for loop unpackages the state from an io monad + state@(varlookup,_,_) <- ioWrappedState; + let + -- each iteration of the loop consists of unpacking the state + loopOnce :: + ComputationState -- ^ The state at this point in the loop + -> OpenscadObj -- ^ The value of vsymb for this iteration + -> ComputationState -- ^ The resulting state + loopOnce ioWrappedState val = do + (varlookup, a, b) <- ioWrappedState; + let + vsymbSetState = return (insert vsymb val varlookup, a, b) + runComputations vsymbSetState loopStatements + -- Then loops once for every entry in vexpr + foldl (loopOnce) (return state) $ case vexpr varlookup of + OList l -> l; + _ -> []; + ) "for statement" + +moduleWithSuite :: + String -> ([ComputationStateModifier] -> ArgParser ComputationStateModifier) + -> GenParser Char st ComputationStateModifier +moduleWithSuite name argHandeler = (do + string name; + many space; + (unnamed, named) <- moduleArgsUnit + many space; + statements <- suite + return $ \ ioWrappedState -> do + state@(varlookup, obj2s, obj3s) <- ioWrappedState + case argMap + (map ($varlookup) unnamed) + (map (\(a,b) -> (a, b varlookup)) named) (argHandeler statements) + of + Just computationModifier -> computationModifier (return state) + Nothing -> (return state); + ) (name ++ " statement") + + +getAndModUpObj2s :: (Monad m) => [ComputationStateModifier] + -> (Obj2Type -> Obj3Type) + -> m ComputationStateModifier +getAndModUpObj2s suite obj2mod = + return $ \ ioWrappedState -> do + (varlookup, obj2s, obj3s) <- ioWrappedState + (varlookup2, obj2s2, obj3s2) <- runComputations (return (varlookup, [], [])) suite + return + (varlookup2, + obj2s, + obj3s ++ (case obj2s2 of [] -> []; x:xs -> [obj2mod x]) ) + +getAndCompressSuiteObjs :: (Monad m) => [ComputationStateModifier] + -> ([Obj2Type] -> Obj2Type) + -> ([Obj3Type] -> Obj3Type) + -> m ComputationStateModifier +getAndCompressSuiteObjs suite obj2modifier obj3modifier = + return $ \ ioWrappedState -> do + (varlookup, obj2s, obj3s) <- ioWrappedState + (varlookup2, obj2s2, obj3s2) <- runComputations (return (varlookup, [], [])) suite + return + (varlookup2, + obj2s ++ (case obj2s2 of [] -> []; _ -> [obj2modifier obj2s2]), + obj3s ++ (case obj3s2 of [] -> []; _ -> [obj3modifier obj3s2]) ) + +getAndTransformSuiteObjs :: (Monad m) => [ComputationStateModifier] + -> (Obj2Type -> Obj2Type) + -> (Obj3Type -> Obj3Type) + -> m ComputationStateModifier +getAndTransformSuiteObjs suite obj2modifier obj3modifier = + return $ \ ioWrappedState -> do + (varlookup, obj2s, obj3s) <- ioWrappedState + (varlookup2, obj2s2, obj3s2) <- runComputations (return (varlookup, [], [])) suite + return + (varlookup2, + obj2s ++ (map obj2modifier obj2s2), + obj3s ++ (map obj3modifier obj3s2) ) + + +unionStatement = moduleWithSuite "union" $ \suite -> do + r <- realArgumentWithDefault "r" 0.0 + if r > 0 + then getAndCompressSuiteObjs suite (Op.unionR r) (Op.unionR r) + else getAndCompressSuiteObjs suite Op.union Op.union + +intersectStatement = moduleWithSuite "intersection" $ \suite -> do + r <- realArgumentWithDefault "r" 0.0 + if r > 0 + then getAndCompressSuiteObjs suite (Op.intersectR r) (Op.intersectR r) + else getAndCompressSuiteObjs suite Op.intersect Op.intersect + +differenceStatement = moduleWithSuite "difference" $ \suite -> do + r <- realArgumentWithDefault "r" 0.0 + if r > 0 + then getAndCompressSuiteObjs suite (Op.differenceR r) (Op.differenceR r) + else getAndCompressSuiteObjs suite Op.difference Op.difference + +translateStatement = moduleWithSuite "translate" $ \suite -> do + v <- argument "v" + case v of + OList ((ONum x):(ONum y):(ONum z):[]) -> + getAndTransformSuiteObjs suite (Op.translate (x,y) ) (Op.translate (x,y,z)) + OList ((ONum x):(ONum y):[]) -> + getAndTransformSuiteObjs suite (Op.translate (x,y) ) (Op.translate (x,y,0.0)) + OList ((ONum x):[]) -> + getAndTransformSuiteObjs suite (Op.translate (x,0.0) ) (Op.translate (x,0.0,0.0)) + ONum x -> + getAndTransformSuiteObjs suite (Op.translate (x,0.0) ) (Op.translate (x,0.0,0.0)) + _ -> noChange + +-- This is mostly insane +rotateStatement = moduleWithSuite "rotate" $ \suite -> do + a <- argument "a" + case a of + ONum xy -> getAndTransformSuiteObjs suite (Op.rotateXY xy ) (Op.rotate3 (xy, 0, 0) ) + OList ((ONum yz):(ONum xz):(ONum xy):[]) -> + getAndTransformSuiteObjs suite (Op.rotateXY xy ) (Op.rotate3 (yz, xz, xy) ) + OList ((ONum yz):(ONum xz):[]) -> + getAndTransformSuiteObjs suite (id ) (Op.rotate3 (yz, xz, 0)) + OList ((ONum yz):[]) -> + getAndTransformSuiteObjs suite (id) (Op.rotate3 (yz, 0, 0)) + _ -> noChange + + +scaleStatement = moduleWithSuite "scale" $ \suite -> do + v <- argument "v" + case v of + {-OList ((ONum x):(ONum y):(ONum z):[]) -> + getAndTransformSuiteObjs suite (Op.translate (x,y) ) (Op.translate (x,y,z)) + OList ((ONum x):(ONum y):[]) -> + getAndTransformSuiteObjs suite (Op.translate (x,y) ) (Op.translate (x,y,0.0)) + OList ((ONum x):[]) -> + getAndTransformSuiteObjs suite (Op.translate (x,0.0) ) (Op.translate (x,0.0,0.0)-} + ONum s -> + getAndTransformSuiteObjs suite (Op.scale s) (Op.scale s) + +extrudeStatement = moduleWithSuite "linear_extrude" $ \suite -> do + height <- realArgument "height" + center <- boolArgumentWithDefault "center" False + twist <- argumentWithDefault "twist" (ONum 0) + r <- realArgumentWithDefault "r" 0 + let + degRotate = (\θ (x,y) -> (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ))) . (*(2*pi/360)) + shiftAsNeeded = + if center + then Op.translate (0,0,-height/2.0) + else id + case twist of + ONum 0 -> getAndModUpObj2s suite (\obj -> shiftAsNeeded $ Op.extrudeR r obj height) + ONum rot -> + getAndModUpObj2s suite (\obj -> + shiftAsNeeded $ Op.extrudeRMod r + (degRotate . (*(rot/height))) + obj height + ) + OFunc rotf -> + getAndModUpObj2s suite (\obj -> + shiftAsNeeded $ Op.extrudeRMod r + (\h -> degRotate $ case rotf (ONum h) of + ONum n -> n + _ -> 0 + ) obj height + ) + +{-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 -> Op.extrudeRMod r (\θ (x,y) -> (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ)) ) obj h) +-} + +shellStatement = moduleWithSuite "shell" $ \suite -> do + w <- realArgumentWithDefault "w" 0.0 + getAndTransformSuiteObjs suite (Op.shell w) (Op.shell w) + diff --git a/Graphics/Implicit/ExtOpenScad/Util.hs b/Graphics/Implicit/ExtOpenScad/Util.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/ExtOpenScad/Util.hs @@ -0,0 +1,150 @@ +module Graphics.Implicit.ExtOpenScad.Util where + +import Prelude hiding (lookup) +import Graphics.Implicit.Definitions +import Graphics.Implicit.ExtOpenScad.Definitions +import Graphics.Implicit.ExtOpenScad.Expressions +import Data.Map (Map, lookup, insert) +import qualified Data.List +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr +import Control.Monad (liftM) + +instance Monad ArgParser where + (ArgParser str fallback f) >>= g = ArgParser str fallback (\a -> (f a) >>= g) + (ArgParserTerminator a) >>= g = g a + (ArgParserFail) >>= g = ArgParserFail + return a = ArgParserTerminator a + +argMap :: [OpenscadObj] -> [(String, OpenscadObj)] -> ArgParser a -> Maybe a +argMap _ _ (ArgParserTerminator a) = Just a +argMap _ _ ArgParserFail = Nothing +argMap (x:unnamedArgs) namedArgs (ArgParser _ _ f) = + argMap unnamedArgs namedArgs (f x) +argMap [] namedArgs (ArgParser str fallback f) = case Data.List.lookup str namedArgs of + Just a -> argMap [] namedArgs (f a) + Nothing -> case fallback of + Just b -> argMap [] namedArgs (f b) + Nothing -> Nothing + +argument :: String -> ArgParser OpenscadObj +argument str = ArgParser str Nothing (\a -> return a) + +realArgument :: String -> ArgParser ℝ +realArgument str = ArgParser str Nothing (\a -> case a of {(ONum a) -> return a; _ -> ArgParserFail;}) + +intArgument :: String -> ArgParser Int +intArgument str = ArgParser str Nothing (\a -> case a of {(ONum a) -> return (floor a); _ -> ArgParserFail;}) + +boolArgument :: String -> ArgParser Bool +boolArgument str = ArgParser str Nothing (\a -> case a of {(OBool a) -> return a; _ -> ArgParserFail;}) + +argumentWithDefault :: String -> OpenscadObj -> ArgParser OpenscadObj +argumentWithDefault str fallback = ArgParser str (Just fallback) (\a -> return a) + +realArgumentWithDefault :: String -> ℝ -> ArgParser ℝ +realArgumentWithDefault str fallback = ArgParser str (Just (ONum fallback)) + (\a -> case a of {(ONum a) -> return a; _ -> ArgParserFail;}) + +intArgumentWithDefault :: String -> Int -> ArgParser Int +intArgumentWithDefault str fallback = ArgParser str (Just (ONum (fromIntegral fallback))) + (\a -> case a of {(ONum a) -> return (floor a); _ -> ArgParserFail;}) + +boolArgumentWithDefault :: String -> Bool -> ArgParser Bool +boolArgumentWithDefault str fallback = ArgParser str (Just (OBool fallback)) + (\a -> case a of {(OBool a) -> return a; _ -> ArgParserFail;}) + +addObj2 :: (Monad m) => Obj2Type -> m ComputationStateModifier +addObj2 obj = return $ \ ioWrappedState -> do + (varlookup, obj2s, obj3s) <- ioWrappedState + return (varlookup, obj2s ++ [obj], obj3s) + +addObj3 :: (Monad m) => Obj3Type -> m ComputationStateModifier +addObj3 obj = return $ \ ioWrappedState -> do + (varlookup, obj2s, obj3s) <- ioWrappedState + return (varlookup, obj2s, obj3s ++ [obj]) + +changeObjs :: (Monad m) => ([Obj2Type] -> [Obj2Type]) -> ([Obj3Type] -> [Obj3Type]) -> m ComputationStateModifier +changeObjs mod2s mod3s = return $ \ ioWrappedState -> do + (varlookup, obj2s, obj3s) <- ioWrappedState + return (varlookup, mod2s obj2s, mod3s obj3s) + +runIO :: (Monad m) => IO() -> m ComputationStateModifier +runIO newio = return $ \ ioWrappedState -> do + state <- ioWrappedState + newio + return state + +noChange :: (Monad m) => m ComputationStateModifier +noChange = return id + +moduleArgsUnit :: + GenParser Char st ([VariableLookup -> OpenscadObj], [(String, VariableLookup -> OpenscadObj)]) +moduleArgsUnit = do + char '('; + many space; + args <- sepBy ( + (try $ do + symb <- variableSymb; + many space; + char '='; + many space; + expr <- expression 0; + return $ Right (symb, expr); + ) <|> (try $ do + symb <- variableSymb; + many space; + char '(' + many space + argVars <- sepBy variableSymb (many space >> char ',' >> many space) + char ')' + many space + char '='; + many space; + expr <- expression 0; + let + makeFunc baseExpr (argVar:xs) varlookup' = OFunc $ + \argObj -> makeFunc baseExpr xs (insert argVar argObj varlookup') + makeFunc baseExpr [] varlookup' = baseExpr varlookup' + funcExpr = makeFunc expr argVars + return $ Right (symb, funcExpr); + ) <|> (do { + expr <- expression 0; + return $ Left expr; + }) + ) (many space >> char ',' >> many space); + many space; + char ')'; + let + isRight (Right a) = True + isRight _ = False + named = map (\(Right a) -> a) $ filter isRight $ args + unnamed = map (\(Left a) -> a) $ filter (not . isRight) $ args + in return (unnamed, named) + + +moduleWithoutSuite :: + String -> ArgParser ComputationStateModifier -> GenParser Char st ComputationStateModifier + +moduleWithoutSuite name argHandeler = (do + string name; + many space; + (unnamed, named) <- moduleArgsUnit + return $ \ ioWrappedState -> do + state@(varlookup, obj2s, obj3s) <- ioWrappedState + case argMap + (map ($varlookup) unnamed) + (map (\(a,b) -> (a, b varlookup)) named) argHandeler + of + Just computationModifier -> computationModifier (return state) + Nothing -> (return state); + ) name + + +pad parser = do + many space + a <- parser + many space + return a + + diff --git a/Graphics/Implicit/Operations.hs b/Graphics/Implicit/Operations.hs --- a/Graphics/Implicit/Operations.hs +++ b/Graphics/Implicit/Operations.hs @@ -1,93 +1,40 @@ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU GPL, see LICENSE -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} module Graphics.Implicit.Operations ( + BasicObj, MagnitudeObj, translate, scale, + rotateXY, complement, - union, intersect, difference, - unionR, intersectR, differenceR, + union, intersect, difference, + unionR, intersectR, differenceR, + outset, shell, - slice, - bubble, - extrude, - extrudeR, - extrudeOnEdgeOf + extrudeR, extrudeRMod, + extrudeOnEdgeOf, + rotate3 ) where -import Prelude hiding ((+),(-),(*),(/)) -import Graphics.Implicit.Definitions -import Graphics.Implicit.MathUtil -import Graphics.Implicit.SaneOperators +-- classes in here provide basicaly everything we're exporting... +import Graphics.Implicit.Operations.Definitions +-- Then we have a bunch of isntances, corresponding to each file name. +import Graphics.Implicit.Operations.Obj2 +import Graphics.Implicit.Operations.Obj3 +import Graphics.Implicit.Operations.ObjPair +import Graphics.Implicit.Operations.BoxedObj2 +import Graphics.Implicit.Operations.BoxedObj3 +import Graphics.Implicit.Operations.BoxedObjPair +import Graphics.Implicit.Operations.SymbolicObj2 +import Graphics.Implicit.Operations.SymbolicObj3 +import Graphics.Implicit.Operations.SymbolicObjPair --- | Translate an object by a vector of appropriate dimension. -translate :: - (Additive a a a, AdditiveInvertable a) - => a -- ^ Vector to translate by (Also: a is a vector, blah, blah) - -> (a -> ℝ) -- ^ Object to translate - -> (a -> ℝ) -- ^ Resulting object -translate p obj = \q -> obj (q-p) --- | Scale an object -scale :: (Multiplicative a ℝ a) => - ℝ -- ^ Amount to scale by - -> (a -> ℝ) -- ^ Object to scale - -> (a -> ℝ) -- ^ Resulting scaled object -scale s obj = \p -> s * obj (p/s) -complement :: - (a -> ℝ) -- ^ Object to complement - -> (a -> ℝ) -- ^ Result -complement obj = \p -> - obj p - -shell :: - ℝ -- ^ width of shell - -> (a -> ℝ) -- ^ object to take shell of - -> (a -> ℝ) -- ^ resulting shell -shell w a = \p -> abs (a p) - w/(2.0::ℝ) - --- | Rounded union -unionR :: - ℝ -- ^ The radius of rounding - -> [a -> ℝ] -- ^ objects to union - -> (a -> ℝ) -- ^ Resulting object -unionR r objs = \p -> rminimum r $ map ($p) objs - --- | Rounded minimum -intersectR :: - ℝ -- ^ The radius of rounding - -> [a -> ℝ] -- ^ Objects to intersect - -> (a -> ℝ) -- ^ Resulting object -intersectR r objs = \p -> rmaximum r $ map ($p) objs - --- | Rounded difference -differenceR :: - ℝ -- ^ The radius of rounding - -> [a -> ℝ] -- ^ Objects to difference - -> (a -> ℝ) -- ^ Resulting object -differenceR r (x:xs) = \p -> rmaximum r $ (x p) :(map (negate . ($p)) xs) - - --- | Union a list of objects -union :: - [a -> ℝ] -- ^ List of objects to union - -> (a -> ℝ) -- ^ The object resulting from the union -union objs = \p -> minimum $ map ($p) objs - --- | Intersect a list of objects -intersect :: - [a -> ℝ] -- ^ List of objects to intersect - -> (a -> ℝ) -- ^ The object resulting from the intersection -intersect objs = \p -> maximum $ map ($p) objs - --- | Difference a list of objects -difference :: - [a -> ℝ] -- ^ List of objects to difference - -> (a -> ℝ) -- ^ The object resulting from the difference -difference (obj:objs) = \p -> maximum $ map ($p) $ obj:(map complement objs) +{- Old stuff that may need to be incorporated into the larger structure later -- | Slice a 3D objects at a given z value to make a 2D object. slice :: @@ -96,14 +43,6 @@ -> Obj2 -- ^ Resulting 2D object slice z obj = \(a,b) -> obj (a,b,z) --- | Bubble out a 2D object into a 3D one. -bubble :: ℝ -> Obj2 -> Obj3 -bubble s obj = - let - spsqrt n = signum n * sqrt (abs n) - spsq n = signum n * n ** 2 - in - \(x,y,z) -> spsqrt ( z ** 2 + s * obj (x,y) ) -- | Extrude a 2D object. (The extrusion goes into the z-plane) extrude :: @@ -128,3 +67,5 @@ -> Obj3 -- ^ Resulting 3D object extrudeOnEdgeOf a b = \(x,y,z) -> a (b (x,y), z) + +-} diff --git a/Graphics/Implicit/Operations/Box2.hs b/Graphics/Implicit/Operations/Box2.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Operations/Box2.hs @@ -0,0 +1,68 @@ + +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Operations.Box2 where + +import Prelude hiding ((+),(-),(*),(/)) +import Graphics.Implicit.Operations.Definitions +import Graphics.Implicit.Definitions +import Graphics.Implicit.MathUtil +import Graphics.Implicit.SaneOperators + + +-- CSG on 2D boxes +-- Not precise, since not all CSG of such is a 2D box, +-- but result will be a super set. We will use this for bounding boxes. +-- Empty boxes will always be ((0,0),(0,0)) for convenience :) +instance BasicObj Box2 ℝ2 where + translate _ ((0,0),(0,0)) = ((0,0),(0,0)) + translate p (a,b) = (a+p, b+p) + scale s (a,b) = (s*a, s*b) + rotateXY θ ((x1,y1),(x2,y2)) = + let + rotate (x,y) = ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x) + (xa, ya) = rotate (x1, y1) + (xb, yb) = rotate (x1, y2) + (xc, yc) = rotate (x2, y1) + (xd, yd) = rotate (x2, y2) + minx = minimum [xa, xb, xc, xd] + miny = minimum [ya, yb, yc, yd] + maxx = maximum [xa, xb, xc, xd] + maxy = maximum [ya, yb, yc, yd] + in + ((minx, miny), (maxx, maxy)) + complement _ = ((-infty, -infty), (infty, infty)) + union boxes = ((left,bot),(right,top)) where + isEmpty = ( == ((0,0),(0,0)) ) + (leftbot, topright) = unzip $ filter (not.isEmpty) boxes + (lefts, bots) = unzip leftbot + (rights, tops) = unzip topright + left = minimum lefts + bot = minimum bots + right = maximum rights + top = maximum tops + intersect boxes = + let + (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 + if top > bot && right > left + then ((left,bot),(right,top)) + else ((0,0),(0,0)) + difference (firstBox : otherBoxes) = firstBox + + +instance MagnitudeObj Box2 where + outset d (a,b) = (a - (d,d), b + (d,d)) + shell w (a,b) = (a - (w/(2.0::ℝ),w/(2.0::ℝ)), b + (w/(2.0::ℝ),w/(2.0::ℝ))) + unionR r boxes = outset r $ union boxes + intersectR r boxes = outset r $ intersect boxes + differenceR r boxes = outset r $ difference boxes diff --git a/Graphics/Implicit/Operations/Box3.hs b/Graphics/Implicit/Operations/Box3.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Operations/Box3.hs @@ -0,0 +1,65 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Operations.Box3 where + +import Prelude hiding ((+),(-),(*),(/)) +import Graphics.Implicit.Operations.Definitions +import Graphics.Implicit.Definitions +import Graphics.Implicit.MathUtil +import Graphics.Implicit.SaneOperators + +instance BasicObj Box3 ℝ3 where + translate _ ((0,0,0),(0,0,0)) = ((0,0,0),(0,0,0)) + translate p (a,b) = (a+p, b+p) + scale s (a,b) = (s*a, s*b) + rotateXY θ ((x1,y1,z1),(x2,y2,z2)) = + let + rotate (x,y) = ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x) + (xa, ya) = rotate (x1, y1) + (xb, yb) = rotate (x1, y2) + (xc, yc) = rotate (x2, y1) + (xd, yd) = rotate (x2, y2) + minx = minimum [xa, xb, xc, xd] + miny = minimum [ya, yb, yc, yd] + maxx = maximum [xa, xb, xc, xd] + maxy = maximum [ya, yb, yc, yd] + in + ((minx, miny,z1), (maxx, maxy,z2)) + complement _ = ((-infty, -infty,-infty), (infty, infty, infty)) + union boxes = ((left,bot,inward),(right,top,out)) where + 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 + intersect boxes = + let + (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)) + difference (firstBox : otherBoxes) = firstBox + +instance MagnitudeObj Box3 where + outset d (a,b) = (a - (d,d,d), b + (d,d,d)) + shell w (a,b) = (a - (w/(2.0::ℝ),w/(2.0::ℝ),w/(2.0::ℝ)), b + (w/(2.0::ℝ),w/(2.0::ℝ),w/(2.0::ℝ))) + unionR r boxes = outset r $ union boxes + intersectR r boxes = outset r $ intersect boxes + differenceR r boxes = outset r $ difference boxes diff --git a/Graphics/Implicit/Operations/BoxPair.hs b/Graphics/Implicit/Operations/BoxPair.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Operations/BoxPair.hs @@ -0,0 +1,30 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + + +module Graphics.Implicit.Operations.BoxPair where + +import Graphics.Implicit.Definitions +import Graphics.Implicit.Operations.Definitions + + +-- | Operations that are specific to some part of a +-- 2D-3D dimensional object pair. +instance PairObj Box2 ℝ2 Box3 ℝ3 where + + extrudeR _ ((x1,y1),(x2,y2)) h = ((x1,y1,0),(x2,y2,h)) + -- This is kind of tricky, because we have no idea what kind of crazy function will come up with... + -- So we're going to give them 3x play space. We'll mention people should mostly shrink objs... + -- I fully intend to do crazy symbolic stuff almost everywhere, so I'm not too worried about speed. + extrudeRMod _ _ ((x1,y1),(x2,y2)) h = ((x1 - dx, y1 - dy, 0),(x2 + dx, y2+ dy, h)) + where + dx = x2 - x1 + dy = y2 - y1 + extrudeOnEdgeOf ((ax1,ay1),(ax2,ay2)) ((bx1,by1),(bx2,by2)) = + ((bx1+ax1, by1+ax1, ay2), (bx2+ax2, by2+ax2, ay2)) + rotate3 _ ((x1,y1, z1),(x2,y2, z2)) = ( (-d, -d, -d), (d, d, d) ) + where + d = (sqrt 2 *) $ maximum $ map abs [x1, x2, y1, y2, z1, z2] + diff --git a/Graphics/Implicit/Operations/BoxedObj2.hs b/Graphics/Implicit/Operations/BoxedObj2.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Operations/BoxedObj2.hs @@ -0,0 +1,38 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Operations.BoxedObj2 where + +import Prelude hiding ((+),(-),(*),(/)) +import Graphics.Implicit.Operations.Definitions +import Graphics.Implicit.Operations.Box2 +import Graphics.Implicit.Operations.Obj2 +import Graphics.Implicit.Definitions +import Graphics.Implicit.MathUtil +import Graphics.Implicit.SaneOperators + + +instance BasicObj (Boxed2 Obj2) ℝ2 where + translate p (obj, box) = (translate p obj, translate p box) + scale s (obj, box) = (scale s obj, scale s box) + rotateXY θ (obj, box) = (rotateXY θ obj, rotateXY θ box) + complement (obj, box) = (complement obj, complement box ) + union bobjs = (union objs, union boxes) where + (objs, boxes) = unzip bobjs + intersect bobjs = (intersect objs, intersect boxes) where + (objs, boxes) = unzip bobjs + difference bobjs = (difference objs, difference boxes) where + (objs, boxes) = unzip bobjs + + +instance MagnitudeObj (Boxed2 Obj2) where + outset d (obj, box) = (outset d obj, outset d box) + shell w (obj, box) = (shell w obj, shell w box) + unionR r bobjs = (unionR r objs, unionR r boxes) where + (objs, boxes) = unzip bobjs + intersectR r bobjs = (intersectR r objs, intersectR r boxes) where + (objs, boxes) = unzip bobjs + differenceR r bobjs = (differenceR r objs, differenceR r boxes) where + (objs, boxes) = unzip bobjs diff --git a/Graphics/Implicit/Operations/BoxedObj3.hs b/Graphics/Implicit/Operations/BoxedObj3.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Operations/BoxedObj3.hs @@ -0,0 +1,36 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Operations.BoxedObj3 where + +import Prelude hiding ((+),(-),(*),(/)) +import Graphics.Implicit.Operations.Definitions +import Graphics.Implicit.Operations.Box3 +import Graphics.Implicit.Operations.Obj3 +import Graphics.Implicit.Definitions +import Graphics.Implicit.MathUtil +import Graphics.Implicit.SaneOperators + +instance BasicObj (Boxed3 Obj3) ℝ3 where + translate p (obj, box) = (translate p obj, translate p box) + scale s (obj, box) = (scale s obj, scale s box) + rotateXY θ (obj, box) = (rotateXY θ obj, rotateXY θ box) + complement (obj, box) = (complement obj, complement box ) + union bobjs = (union objs, union boxes) where + (objs, boxes) = unzip bobjs + intersect bobjs = (intersect objs, intersect boxes) where + (objs, boxes) = unzip bobjs + difference bobjs = (difference objs, difference boxes) where + (objs, boxes) = unzip bobjs + +instance MagnitudeObj (Boxed3 Obj3) where + outset d (obj, box) = (outset d obj, outset d box) + shell w (obj, box) = (shell w obj, shell w box) + unionR r bobjs = (unionR r objs, unionR r boxes) where + (objs, boxes) = unzip bobjs + intersectR r bobjs = (intersectR r objs, intersectR r boxes) where + (objs, boxes) = unzip bobjs + differenceR r bobjs = (differenceR r objs, differenceR r boxes) where + (objs, boxes) = unzip bobjs diff --git a/Graphics/Implicit/Operations/BoxedObjPair.hs b/Graphics/Implicit/Operations/BoxedObjPair.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Operations/BoxedObjPair.hs @@ -0,0 +1,22 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + + +module Graphics.Implicit.Operations.BoxedObjPair where + +import Graphics.Implicit.Definitions +import Graphics.Implicit.Operations.Definitions +import Graphics.Implicit.Operations.ObjPair +import Graphics.Implicit.Operations.BoxPair + + +-- | Operations that are specific to some part of a +-- 2D-3D dimensional object pair. +instance PairObj BoxedObj2 ℝ2 BoxedObj3 ℝ3 where + + extrudeR r (obj, box) h = (extrudeR r obj h, extrudeR r box h) + extrudeRMod r mod (obj, box) h = (extrudeRMod r mod obj h, extrudeRMod r mod box h) + extrudeOnEdgeOf (obj1, box1) (obj2, box2) = (extrudeOnEdgeOf obj1 obj2, extrudeOnEdgeOf box1 box2) + rotate3 rot (obj, box) = (rotate3 rot obj, rotate3 rot box) diff --git a/Graphics/Implicit/Operations/Definitions.hs b/Graphics/Implicit/Operations/Definitions.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Operations/Definitions.hs @@ -0,0 +1,141 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + + +module Graphics.Implicit.Operations.Definitions where + +import Graphics.Implicit.Definitions + + +infty = (1 :: ℝ) / (0 :: ℝ) + +-- | Very basic operations objects +class BasicObj 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 + + -- | Scale an object + scale :: + ℝ -- ^ Amount to scale by + -> obj -- ^ Object to scale + -> obj -- ^ Resulting scaled object + + rotateXY :: + ℝ -- ^ Amount to rotate by + -> obj -- ^ Object to rotate + -> obj -- ^ Resulting rotated object + + -- | Complement an Object + complement :: + obj -- ^ Object to complement + -> obj -- ^ Result + + -- | Union a list of objects + union :: + [obj] -- ^ List of objects to union + -> obj -- ^ The object resulting from the union + + -- | Difference a list of objects + difference :: + [obj] -- ^ List of objects to difference + -> obj -- ^ The object resulting from the difference + + -- | Intersect a list of objects + intersect :: + [obj] -- ^ List of objects to intersect + -> obj -- ^ The object resulting from the intersection + + + + + +-- | Operations that involve an idea of how far you are outwards +class MagnitudeObj obj where + + -- | 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 + + -- | 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 + + +-- | Inset an object. +inset :: MagnitudeObj obj => + ℝ -- ^ distance to inset + -> obj -- ^ object to inset + -> obj -- ^ resulting object +inset d obj = outset (-d) obj + + +-- | Operations that are specific to some part of a +-- 2D-3D dimensional object pair. +class PairObj obj2 vec2 obj3 vec3 + | obj2 -> vec2, obj3 -> vec3, obj2 -> obj3, obj3 -> obj2 + where + + -- | Extrude a rounded object + extrudeR :: + ℝ -- ^ Radius of rounding + -> obj2 -- ^ 2D Object to extrude + -> ℝ -- ^ length to extrude it + -> obj3 -- ^ Resulting 3D object + + -- | Extrude a rounded 2D object, modifying it over height + -- Comment: Technically, extrudeR = extrudeRMod id, but then we + -- couldn't be clever with symbolics :) + extrudeRMod :: + ℝ -- ^ Radius of rounding + -> (ℝ -> ℝ2 -> ℝ2) -- ^ Function to modify each layer: + -- Height transforming at, + -- Input 2D transform, + -- New point! + -> obj2 -- ^ 2D Object to extrude + -> ℝ -- ^ length to extrude it + -> obj3 -- ^ Resulting 3D object + + -- | Extrude one 2D object about the edge of another. + -- Example: 2 circles produce a torus + -- Comment: extrudeOnEdgeOf a b can be thought of as a + -- projection of a×b. + extrudeOnEdgeOf :: + obj2 -- ^ Object to extrude + -> obj2 -- ^ Object to extrude along the edge of + -> obj3 -- ^ Resulting 3D object + + -- | Like openscad rotate... + -- Comment: Rotations are not abelian -- watch out! + rotate3 :: + (ℝ, ℝ, ℝ) -- ^ Rotater (YZ, XZ, XY) + -> obj3 -- ^ Object to rotate + -> obj3 -- ^ Resulting object + diff --git a/Graphics/Implicit/Operations/Obj2.hs b/Graphics/Implicit/Operations/Obj2.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Operations/Obj2.hs @@ -0,0 +1,29 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Operations.Obj2 where + +import Prelude hiding ((+),(-),(*),(/)) +import Graphics.Implicit.Operations.Definitions +import Graphics.Implicit.Definitions +import Graphics.Implicit.MathUtil +import Graphics.Implicit.SaneOperators + + +instance BasicObj Obj2 ℝ2 where + translate p obj = \q -> obj (q-p) + scale s obj = \p -> s * obj (p/s) + rotateXY θ obj = \(x,y) -> obj ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x) + complement obj = \p -> - obj p + union objs = \p -> minimum $ map ($p) objs + intersect objs = \p -> maximum $ map ($p) objs + difference (obj:objs) = \p -> maximum $ map ($p) $ obj:(map complement objs) + +instance MagnitudeObj Obj2 where + outset d obj = \p -> obj p - d + shell w a = \p -> abs (a p) - w/(2.0::ℝ) + unionR r objs = \p -> rminimum r $ map ($p) objs + intersectR r objs = \p -> rmaximum r $ map ($p) objs + differenceR r (x:xs) = \p -> rmaximum r $ (x p) :(map (negate . ($p)) xs) diff --git a/Graphics/Implicit/Operations/Obj3.hs b/Graphics/Implicit/Operations/Obj3.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Operations/Obj3.hs @@ -0,0 +1,29 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Operations.Obj3 where + +import Prelude hiding ((+),(-),(*),(/)) +import Graphics.Implicit.Operations.Definitions +import Graphics.Implicit.Definitions +import Graphics.Implicit.MathUtil +import Graphics.Implicit.SaneOperators + + +instance BasicObj Obj3 ℝ3 where + translate p obj = \q -> obj (q-p) + scale s obj = \p -> s * obj (p/s) + rotateXY θ obj = \(x,y,z) -> obj ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x, z) + complement obj = \p -> - obj p + union objs = \p -> minimum $ map ($p) objs + intersect objs = \p -> maximum $ map ($p) objs + difference (obj:objs) = \p -> maximum $ map ($p) $ obj:(map complement objs) + +instance MagnitudeObj Obj3 where + outset d obj = \p -> obj p - d + shell w a = \p -> abs (a p) - w/(2.0::ℝ) + unionR r objs = \p -> rminimum r $ map ($p) objs + intersectR r objs = \p -> rmaximum r $ map ($p) objs + differenceR r (x:xs) = \p -> rmaximum r $ (x p) :(map (negate . ($p)) xs) diff --git a/Graphics/Implicit/Operations/ObjPair.hs b/Graphics/Implicit/Operations/ObjPair.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Operations/ObjPair.hs @@ -0,0 +1,34 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + + +module Graphics.Implicit.Operations.ObjPair where + +import Graphics.Implicit.Definitions +import Graphics.Implicit.MathUtil +import Graphics.Implicit.Operations.Definitions + + + +instance PairObj Obj2 ℝ2 Obj3 ℝ3 where + + -- Notice that \(x,y,z) = obj2 (x,y) infinitly extrudes a obj2 in both directions. + -- We essentially do that but rounded intersect it to get the desired height. + extrudeR r obj h = \(x,y,z) -> rmax r (obj (x,y)) (abs (z - h/2.0) - h/2.0) + + -- As above, but (obj $ mod z (x,y)) to modify to the object over ehight :) + extrudeRMod r mod obj h = \(x,y,z) -> rmax r (obj $ mod z (x,y)) (abs (z - h/2.0) - h/2.0) + + -- We feed the output of one object as an input to another. + extrudeOnEdgeOf a b = \(x,y,z) -> a (b (x,y), z) + + rotate3 (yz, xz, xy) obj = + let + rotateYZ θ obj = \(x,y,z) -> obj ( x, cos(θ)*z - sin(θ)*y, cos(θ)*y + sin(θ)*z) + rotateXZ θ obj = \(x,y,z) -> obj ( cos(θ)*x + sin(θ)*z, y, cos(θ)*z - sin(θ)*x) + rotateXY θ obj = \(x,y,z) -> obj ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x, z) + in + rotateYZ yz $ rotateXZ xz $ rotateXY xy $ obj + diff --git a/Graphics/Implicit/Operations/SymbolicObj2.hs b/Graphics/Implicit/Operations/SymbolicObj2.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Operations/SymbolicObj2.hs @@ -0,0 +1,29 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Operations.SymbolicObj2 where + +import Prelude hiding ((+),(-),(*),(/)) +import Graphics.Implicit.Operations.Definitions +import Graphics.Implicit.Definitions +import Graphics.Implicit.MathUtil +import Graphics.Implicit.SaneOperators + + +instance BasicObj SymbolicObj2 ℝ2 where + translate = Translate2 + scale = Scale2 + rotateXY = Rotate2 + complement= Complement2 + union = UnionR2 0 + intersect = IntersectR2 0 + difference= DifferenceR2 0 + +instance MagnitudeObj SymbolicObj2 where + outset = Outset2 + shell = Shell2 + unionR = UnionR2 + intersectR = UnionR2 + differenceR = DifferenceR2 diff --git a/Graphics/Implicit/Operations/SymbolicObj3.hs b/Graphics/Implicit/Operations/SymbolicObj3.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Operations/SymbolicObj3.hs @@ -0,0 +1,29 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Operations.SymbolicObj3 where + +import Prelude hiding ((+),(-),(*),(/)) +import Graphics.Implicit.Operations.Definitions +import Graphics.Implicit.Definitions +import Graphics.Implicit.MathUtil +import Graphics.Implicit.SaneOperators + + +instance BasicObj SymbolicObj3 ℝ3 where + translate = Translate3 + scale = Scale3 + rotateXY θ= Rotate3 (0,0, θ) + complement= Complement3 + union = UnionR3 0 + intersect = IntersectR3 0 + difference= DifferenceR3 0 + +instance MagnitudeObj SymbolicObj3 where + outset = Outset3 + shell = Shell3 + unionR = UnionR3 + intersectR = UnionR3 + differenceR = DifferenceR3 diff --git a/Graphics/Implicit/Operations/SymbolicObjPair.hs b/Graphics/Implicit/Operations/SymbolicObjPair.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Operations/SymbolicObjPair.hs @@ -0,0 +1,21 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + + +module Graphics.Implicit.Operations.SymbolicObjPair where + +import Graphics.Implicit.Definitions +import Graphics.Implicit.Operations.Definitions + + +-- | Operations that are specific to some part of a +-- 2D-3D dimensional object pair. +instance PairObj SymbolicObj2 ℝ2 SymbolicObj3 ℝ3 where + + extrudeR = ExtrudeR + extrudeRMod = ExtrudeRMod + extrudeOnEdgeOf = ExtrudeOnEdgeOf + rotate3 = Rotate3 + diff --git a/Graphics/Implicit/Primitives.hs b/Graphics/Implicit/Primitives.hs --- a/Graphics/Implicit/Primitives.hs +++ b/Graphics/Implicit/Primitives.hs @@ -1,102 +1,81 @@ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU GPL, see LICENSE +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + module Graphics.Implicit.Primitives ( sphere, - cube, circle, - cylinder, - square, + cylinder, cylinderC, cylinder2, cylinder2C, + rect3R, rectR, regularPolygon, - polygon, - zsurface--, - --ellipse + polygonR, + zsurface ) where +-- Some type definitions :) import Graphics.Implicit.Definitions -import qualified Graphics.Implicit.SaneOperators as S -sphere :: - ℝ -- ^ Radius of the sphere - -> Obj3 -- ^ Resulting sphere -sphere r = \(x,y,z) -> sqrt (x**2 + y**2 + z**2) - r +-- Most of the functions we're exporting come from here +-- They are methods of classes. +import Graphics.Implicit.Primitives.Definitions -cube :: - ℝ -- ^ Width of the cube - -> Obj3 -- ^ Resuting cube -cube l = \(x,y,z) -> (maximum $ map abs [x,y,z]) - l/2.0 +-- These files implement the classes for types +-- corresponding to the name of the file. +import Graphics.Implicit.Primitives.Obj2 +import Graphics.Implicit.Primitives.Obj3 +import Graphics.Implicit.Primitives.BoxedObj2 +import Graphics.Implicit.Primitives.BoxedObj3 +import Graphics.Implicit.Primitives.SymbolicObj2 +import Graphics.Implicit.Primitives.SymbolicObj3 -cylinder :: - ℝ -- ^ Radius of the cylinder +-- We export a few functions modified by operations +-- for users conveniences... +import Graphics.Implicit.Operations + +-- If you are confused as to how these functions work, please refer to +-- http://christopherolah.wordpress.com/2011/11/06/manipulation-of-implicit-functions-with-an-eye-on-cad/ + +cylinder :: (PrimitiveSupporter3 obj, BasicObj obj ℝ3) => + ℝ -- ^ Radius of the cylinder -> ℝ -- ^ Height of the cylinder - -> Obj3 -- ^ Resulting cylinder -cylinder r h = \(x,y,z) -> max (sqrt(x^2+y^2) - r) (abs(z) - h) + -> obj -- ^ Resulting cylinder +cylinder r h = cylinder2 r r h -circle :: - ℝ -- ^ radius of the circle - -> Obj2 -- ^ resulting circle -circle r = \(x,y) -> sqrt (x**2 + y**2) - r +cylinderC :: (PrimitiveSupporter3 obj, BasicObj obj ℝ3) => + ℝ -- ^ Radius of the cylinder + -> ℝ -- ^ Height of the cylinder + -> obj -- ^ Resulting cylinder +cylinderC r h = translate (0,0,-h/2.0) $ cylinder r h -torus :: - ℝ -- ^ radius of the rotated circle of a torus - -> ℝ -- ^ radius of the circle rotationaly extruded on of a torus - -> Obj3 -- ^ resulting torus -torus r_main r_second = \(x,y,z) -> sqrt( ( sqrt (x^2 + y^2) - r_main )^2 + z^2 ) - r_second ---ellipse :: ℝ -> ℝ -> Obj2 ---ellipse a b = \(x,y) -> --- if a > b --- then ellipse b a (y,x) --- else sqrt ((b/a*x)* *2 + y**2) - a +cylinder2C :: (PrimitiveSupporter3 obj, BasicObj obj ℝ3) => + ℝ -- ^ Radius of the cylinder + -> ℝ -- ^ Second radius of the cylinder + -> ℝ -- ^ Height of the cylinder + -> obj -- ^ Resulting cylinder +cylinder2C r1 r2 h = translate (0,0,-h/2.0) $ cylinder2 r1 r2 h -square :: - ℝ -- ^ Width of the square - -> Obj2 -- ^ Resulting square -square l = \(x,y) -> (maximum $ map abs [x,y]) - l/2.0 -polygon :: - [ℝ2] -- ^ Verticies of the polygon - -> Obj2 -- ^ Resulting polygon -polygon points = - let - pairs = - [ (points !! n, points !! (mod (n+1) (length points) ) ) | n <- [0 .. (length points) - 1] ] - isIn p@(p1,p2) = - let - crossing_points = - [x1 + (x2-x1)*y2/(y2-y1) | - ((x1,y1), (x2,y2)) <- - map (\((a1,a2),(b1,b2)) -> ((a1-p1,a2-p2), (b1-p1,b2-p2)) ) pairs, - ( (y2 < 0) && (y1 > 0) ) || ( (y2 > 0) && (y1 < 0) ) ] - in - if odd $ length $ filter (>0) crossing_points then -1 else 1 - dist a@(a1,a2) b@(b1,b2) p@(p1,p2) = - let - ab = b S.- a - nab = (1 / S.norm ab) S.* ab - ap = p S.- a - d = nab S.⋅ ap - closest - | d < 0 = a - | d > S.norm ab = b - | otherwise = a S.+ d S.* nab - in - S.norm (closest S.- p) - dists = \ p -> map (\(a,b) -> dist a b p) pairs - in - \ p -> isIn p * minimum (dists p) -regularPolygon :: +regularPolygon :: ℕ -- ^ number of sides -> ℝ -- ^ radius -> Obj2 -- ^ resulting regular polygon -regularPolygon sides r = let sidesr = fromIntegral sides in - \(x,y) -> maximum [ x*cos(2*pi*m/sidesr) + y*sin(2*pi*m/sidesr) | m <- [0.. sidesr -1]] - r +regularPolygon sides r = polygonR 0 [ (r*cos(2*pi*m/sidesr), r*sin(2*pi*m/sidesr)) | m <- [0.. sidesr -1]] + where sidesr = fromIntegral sides -zsurface :: +zsurface :: (ℝ2 -> ℝ) -- ^ Description of the height of the surface -> Obj3 -- ^ Resulting 3D object zsurface f = \(x,y,z) -> f (x,y) - z +-- This function is commented out because it doesn't obey the magnitude requirement. +-- Refer to blog post. +-- It needs to be fixed at some point, but the math is somewhat non-trivial. +--ellipse :: ℝ -> ℝ -> Obj2 +--ellipse a b +-- | a < b = \(x,y) -> sqrt ((b/a*x)**2 + y**2) - a +-- | otherwise = \(x,y) -> sqrt (x**2 + (a/b*y)**2) - b diff --git a/Graphics/Implicit/Primitives/BoxedObj2.hs b/Graphics/Implicit/Primitives/BoxedObj2.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Primitives/BoxedObj2.hs @@ -0,0 +1,20 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + + +module Graphics.Implicit.Primitives.BoxedObj2 where + +import Graphics.Implicit.Definitions +import Graphics.Implicit.Primitives.Definitions +import Graphics.Implicit.Primitives.Obj2 + + +instance PrimitiveSupporter2 (Boxed2 Obj2) where + circle r = (circle r, ((-r, -r), (r,r)) ) + rectR r a b = (rectR r a b, ( a,b ) ) + polygonR r points = (polygonR r points, ((minimum xs, minimum ys), (maximum xs, maximum ys)) ) where + (xs, ys) = unzip points + + diff --git a/Graphics/Implicit/Primitives/BoxedObj3.hs b/Graphics/Implicit/Primitives/BoxedObj3.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Primitives/BoxedObj3.hs @@ -0,0 +1,18 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Primitives.BoxedObj3 where + +import Graphics.Implicit.Definitions +import Graphics.Implicit.Primitives.Definitions +import Graphics.Implicit.Primitives.Obj3 + + +instance PrimitiveSupporter3 (Boxed3 Obj3) where + sphere r = (sphere r, ((-r, -r, -r), (r,r,r)) ) + rect3R r a b = (rect3R r a b, ( a, b) ) + cylinder2 r1 r2 h = (cylinder2 r1 r2 h, ( (-r,-r,0), (r,r,h) ) ) where r = max r1 r2 + + diff --git a/Graphics/Implicit/Primitives/Definitions.hs b/Graphics/Implicit/Primitives/Definitions.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Primitives/Definitions.hs @@ -0,0 +1,46 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + + +module Graphics.Implicit.Primitives.Definitions where + +import Graphics.Implicit.Definitions + + +-- Basic Primitive 3D Objects; We can make the others from here. +class PrimitiveSupporter3 obj where + sphere :: + ℝ -- ^ Radius of the sphere + -> obj -- ^ Resulting sphere + rect3R :: + ℝ -- ^ Rounding of corners + -> ℝ3 -- ^ Bottom// corner + -> ℝ3 -- ^ Top right... corner + -> obj -- ^ Resuting cube - (0,0,0) is bottom left... + cylinder2 :: + ℝ -- ^ Radius of the cylinder + -> ℝ -- ^ Second radius of the cylinder + -> ℝ -- ^ Height of the cylinder + -> obj -- ^ Resulting cylinder + + +class PrimitiveSupporter2 obj where + + circle :: + ℝ -- ^ radius of the circle + -> obj -- ^ resulting circle + rectR :: + ℝ + -> ℝ2 -- ^ Bottom left corner + -> ℝ2 -- ^ Top right corner + -> obj -- ^ Resulting square (bottom right = (0,0) ) + polygonR :: + ℝ -- ^ Rouding of the polygon + -> [ℝ2] -- ^ Verticies of the polygon + -> obj -- ^ Resulting polygon + + + + diff --git a/Graphics/Implicit/Primitives/Obj2.hs b/Graphics/Implicit/Primitives/Obj2.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Primitives/Obj2.hs @@ -0,0 +1,49 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Primitives.Obj2 where + +import Graphics.Implicit.Definitions +import Graphics.Implicit.MathUtil +import Graphics.Implicit.Primitives.Definitions +import qualified Graphics.Implicit.SaneOperators as S + + +instance PrimitiveSupporter2 Obj2 where + + circle r = \(x,y) -> sqrt (x**2 + y**2) - r + + rectR r (x1,y1) (x2,y2) = + \(x,y) -> rmaximum r [abs (x- dx/2.0 -x1) -dx/2.0, abs (y- dy/2.0 -y1) - dy/2.0] + where (dx,dy) = (x2-x1,y2-y1) + polygonR 0 points = + let + pairs = + [ (points !! n, points !! (mod (n+1) (length points) ) ) | n <- [0 .. (length points) - 1] ] + isIn p@(p1,p2) = + let + crossing_points = + [x1 + (x2-x1)*y2/(y2-y1) | + ((x1,y1), (x2,y2)) <- + map (\((a1,a2),(b1,b2)) -> ((a1-p1,a2-p2), (b1-p1,b2-p2)) ) pairs, + ( (y2 < 0) && (y1 > 0) ) || ( (y2 > 0) && (y1 < 0) ) ] + in + if odd $ length $ filter (>0) crossing_points then -1 else 1 + dist a@(a1,a2) b@(b1,b2) p@(p1,p2) = + let + ab = b S.- a + nab = (1 / S.norm ab) S.* ab + ap = p S.- a + d = nab S.⋅ ap + closest + | d < 0 = a + | d > S.norm ab = b + | otherwise = a S.+ d S.* nab + in + S.norm (closest S.- p) + dists = \ p -> map (\(a,b) -> dist a b p) pairs + in + \ p -> isIn p * minimum (dists p) + diff --git a/Graphics/Implicit/Primitives/Obj3.hs b/Graphics/Implicit/Primitives/Obj3.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Primitives/Obj3.hs @@ -0,0 +1,21 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Primitives.Obj3 where + +import Graphics.Implicit.Definitions +import Graphics.Implicit.MathUtil +import Graphics.Implicit.Primitives.Definitions + +instance PrimitiveSupporter3 Obj3 where + sphere r = \(x,y,z) -> sqrt (x**2 + y**2 + z**2) - r + rect3R r (x1,y1,z1) (x2,y2,z2) = + \(x,y,z) -> rmaximum r + [abs (x-dx/2.0-x1) - dx/2.0, abs (y-dy/2.0-y1) - dy/2.0, abs (z-dz/2.0-z1) - dz/2.0] + where (dx, dy, dz) = (x2-x1, y2-y1, z2-z1) + cylinder2 r1 r2 h + | r1 == r2 = \(x,y,z) -> max (sqrt(x^2+y^2) - r1) (abs(z-h/2.0) - h/2.0) + | otherwise = \(x,y,z) -> max (sqrt(x^2+y^2) - r1*(1.0 - z/2.0) - r2*z/2.0) (abs(z-h/2.0) - h/2.0) + diff --git a/Graphics/Implicit/Primitives/SymbolicObj2.hs b/Graphics/Implicit/Primitives/SymbolicObj2.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Primitives/SymbolicObj2.hs @@ -0,0 +1,17 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + + +module Graphics.Implicit.Primitives.SymbolicObj2 where + +import Graphics.Implicit.Definitions +import Graphics.Implicit.Primitives.Definitions + + +instance PrimitiveSupporter2 SymbolicObj2 where + circle = Circle + rectR = RectR + polygonR = PolygonR + diff --git a/Graphics/Implicit/Primitives/SymbolicObj3.hs b/Graphics/Implicit/Primitives/SymbolicObj3.hs new file mode 100644 --- /dev/null +++ b/Graphics/Implicit/Primitives/SymbolicObj3.hs @@ -0,0 +1,18 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} + +module Graphics.Implicit.Primitives.SymbolicObj3 where + +import Graphics.Implicit.Definitions +import Graphics.Implicit.Primitives.Definitions +import Graphics.Implicit.Primitives.BoxedObj3 + + +instance PrimitiveSupporter3 SymbolicObj3 where + sphere r = Sphere r + rect3R = Rect3R + cylinder2 r1 r2 h = EmbedBoxedObj3 $ cylinder2 r1 r2 h + + diff --git a/Graphics/Implicit/SaneOperators.hs b/Graphics/Implicit/SaneOperators.hs --- a/Graphics/Implicit/SaneOperators.hs +++ b/Graphics/Implicit/SaneOperators.hs @@ -114,8 +114,14 @@ instance Multiplicative ℝ ℝ2 ℝ2 where s * (x,y) = (s*x, s*y) +instance Multiplicative ℝ2 ℝ ℝ2 where + (x,y)*s = (s*x, s*y) + instance Multiplicative ℝ ℝ3 ℝ3 where s * (x,y,z) = (s*x, s*y, s*z) + +instance Multiplicative ℝ3 ℝ ℝ3 where + (x,y,z) * s = (s*x, s*y, s*z) instance AdditiveInvertable ℝ2 where additiveInverse (x, y) = (additiveInverse x, additiveInverse y) diff --git a/Graphics/Implicit/Tracing.hs b/Graphics/Implicit/Tracing.hs deleted file mode 100644 --- a/Graphics/Implicit/Tracing.hs +++ /dev/null @@ -1,137 +0,0 @@ --- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) --- Released under the GNU GPL, see LICENSE - -module Graphics.Implicit.Tracing ( - getTriangles, - getLineSeg, - orderLines, - orderLinesDC, - orderLinesP, - reducePolyline, - polylineNotNull -) where - -import Graphics.Implicit.Definitions -import Graphics.Implicit.Tracing.GetTriangles (getTriangles) - -import Control.Parallel (par, pseq) - -getLineSeg :: (ℝ,ℝ,ℝ,ℝ,ℝ,ℝ2,ℝ) -> [Polyline] -getLineSeg (x1y1,x2y1,x2y2,x1y2,c,(x,y),s) = - let - x1 = (x, y+s*x1y1/(x1y1-x1y2)) - x2 = (x+s, y+s*x2y1/(x2y1-x2y2)) - y1 = (x+s*x1y1/(x1y1-x2y1), y ) - y2 = (x+s*x1y2/(x1y2-x2y2), y+s) - notPointLine (p1:p2:[]) = p1 /= p2 - in filter (notPointLine) $ case (x1y2 <= 0, x2y2 <= 0, - x1y1 <= 0, x2y1 <= 0) of - (True, True, - True, True) -> [] - (False, False, - False, False) -> [] - (True, True, - False, False) -> [[x1, x2]] - (False, False, - True, True) -> [[x1, x2]] - (False, True, - False, True) -> [[y1, y2]] - (True, False, - True, False) -> [[y1, y2]] - (True, False, - False, False) -> [[x1, y2]] - (False, True, - True, True) -> [[x1, y2]] - (True, True, - False, True) -> [[x1, y1]] - (False, False, - True, False) -> [[x1, y1]] - (True, True, - True, False) -> [[x2, y1]] - (False, False, - False, True) -> [[x2, y1]] - (True, False, - True, True) -> [[x2, y2]] - (False, True, - False, False) -> [[x2, y2]] - (True, False, - False, True) -> if c > 0 - then [[x1, y2], [x2, y1]] - else [[x1, y1], [x2, y2]] - (False, True, - True, False) -> if c <= 0 - then [[x1, y2], [x2, y1]] - else [[x1, y1], [x2, y2]] - - - - -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 - -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) -reducePolyline ((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 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') - - -polylineNotNull (a:l) = not (null l) -polylineNotNull [] = False - - - -{-getMesh (a1, a2, a3) (b1, b2, b3) d obj = - if abs (obj ( (a1 + b1)/2, (a2 + b2)/2, (a3 + b3)/2 )) > 2*d - then [] - else if maximum [ abs $ b1 - a1, abs $ b2 - a2, abs $ b3 - a3 ] < d - then getTriangles-} - diff --git a/Graphics/Implicit/Tracing/GetTriangles.hs b/Graphics/Implicit/Tracing/GetTriangles.hs deleted file mode 100644 --- a/Graphics/Implicit/Tracing/GetTriangles.hs +++ /dev/null @@ -1,416 +0,0 @@ --- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) --- Released under the GNU GPL, see LICENSE - -module Graphics.Implicit.Tracing.GetTriangles (getTriangles) where - -import Graphics.Implicit.Definitions - - --- This monstrosity of a function gives triangles to divde negative interior --- regions and positive exterior ones inside a cube, based on its vertices. - --- It is based on the linearly-interpolated marching cubes algorithm. - -getTriangles :: ((ℝ,ℝ,ℝ,ℝ,ℝ,ℝ,ℝ,ℝ),ℝ3,ℝ) -> [(ℝ3,ℝ3,ℝ3)] -getTriangles ((x1y1z1,x2y1z1,x1y2z1,x2y2z1,x1y1z2,x2y1z2,x1y2z2,x2y2z2), (x,y,z), d) = - let - --{- Linearly interpolated - x1y1 = (x, y, z+d*x1y1z1/(x1y1z1-x1y1z2)) - x1y2 = (x, y+d, z+d*x1y2z1/(x1y2z1-x1y2z2)) - x2y1 = (x+d, y, z+d*x2y1z1/(x2y1z1-x2y1z2)) - x2y2 = (x+d, y+d, z+d*x2y2z1/(x2y2z1-x2y2z2)) - - x1z1 = (x, y+d*x1y1z1/(x1y1z1-x1y2z1), z) - x1z2 = (x, y+d*x1y1z2/(x1y1z2-x1y2z2), z+d) - x2z1 = (x+d, y+d*x2y1z1/(x2y1z1-x2y2z1), z) - x2z2 = (x+d, y+d*x2y1z2/(x2y1z2-x2y2z2), z+d) - - y1z1 = (x+d*x1y1z1/(x1y1z1-x2y1z1), y, z) - y1z2 = (x+d*x1y1z2/(x1y1z2-x2y1z2), y, z+d) - y2z1 = (x+d*x1y2z1/(x1y2z1-x2y2z1), y+d, z) - y2z2 = (x+d*x1y2z2/(x1y2z2-x2y2z2), y+d, z+d) - --} - - - {- Non-linearly interpolated - x1y1 = (x, y, z+d/2) - x1y2 = (x, y+d, z+d/2) - x2y1 = (x+d, y, z+d/2) - x2y2 = (x+d, y+d, z+d/2) - - x1z1 = (x, y+d/2, z) - x1z2 = (x, y+d/2, z+d) - x2z1 = (x+d, y+d/2, z) - x2z2 = (x+d, y+d/2, z+d) - - y1z1 = (x+d/2, y, z) - y1z2 = (x+d/2, y, z+d) - y2z1 = (x+d/2, y+d,z) - y2z2 = (x+d/2, y+d,z+d) - --} - - -- Convenience function - square a b c d = [(a,b,c),(d,a,c)] - in case - -- whether the vertices are "in" or "out" form the topological - -- basis of our triangles constructions. We must consider every - -- possible case. - - -- We arrange the vertices in a human readable way - - -- BOTTOM LAYER TOP LAYER - (x1y2z1<=0, x2y2z1<=0, x1y2z2<=0, x2y2z2<=0, - x1y1z1<=0, x2y1z1<=0, x1y1z2<=0, x2y1z2<=0) - of - - -- There are 256 cases to implement. - -- Only about half are, but they're the most common ones. - -- In practice, this has no issues redering reasonable objects. - - -- Uniform cases = empty - (False,False, False,False, - False,False, False,False) -> [] - - (True, True, True, True, - True, True, True, True ) -> [] - - -- 2 uniform layers - - (True, True, False,False, - True, True, False,False) -> square x1y1 x2y1 x2y2 x1y2 - - (False,False, True, True, - False,False, True, True ) -> square x1y1 x2y1 x2y2 x1y2 - - (True, True, True, True, - False,False, False,False) -> square x1z1 x2z1 x2z2 x1z2 - - (False,False, False,False, - True, True, True, True ) -> square x1z1 x2z1 x2z2 x1z2 - - (False,True, False,True, - False,True, False,True ) -> square y1z1 y2z1 y2z2 y1z2 - - (True, False, True, False, - True, False, True, False) -> square y1z1 y2z1 y2z2 y1z2 - - - -- z single column - - (True, False, True, False, - False,False, False,False) -> square x1z1 y2z1 y2z2 x1z2 - - (False,True, False,True, - False,False, False,False) -> square x2z1 y2z1 y2z2 x2z2 - - (False,False, False,False, - True, False, True, False) -> square x1z1 y1z1 y1z2 x1z2 - - (False,False, False,False, - False,True, False,True ) -> square y1z1 x2z1 x2z2 y1z2 - - (False,True, False,True, - True, True, True, True ) -> square x1z1 y2z1 y2z2 x1z2 - - (True, False, True, False, - True, True, True, True ) -> square x2z1 y2z1 y2z2 x2z2 - - (True, True, True, True, - False,True, False,True ) -> square x1z1 y1z1 y1z2 x1z2 - - (True, True, True, True, - True, False, True, False) -> square y1z1 x2z1 x2z2 y1z2 - - -- single y column - - (True, False, False,False, - True, False, False,False) -> square x1y1 y1z1 y2z1 x1y2 - - (False,True, False,False, - False,True, False,False) -> square x2y1 y1z1 y2z1 x2y2 - - (False,False, True, False, - False,False, True, False) -> square x1y1 y1z2 y2z2 x1y2 - - (False,False, False,True, - False,False, False,True ) -> square x2y1 y1z2 y2z2 x2y2 - - (False,True, True, True, - False,True, True, True) -> square x1y1 y1z1 y2z1 x1y2 - - (True, False, True, True, - True, False, True, True) -> square x2y1 y1z1 y2z1 x2y2 - - (True, True, False, True, - True, True, False, True) -> square x1y1 y1z2 y2z2 x1y2 - - (True, True, True, False, - True, True, True, False) -> square x2y1 y1z2 y2z2 x2y2 - - -- since x column - - (True, True, False,False, - False,False, False,False) -> square x1y2 x1z1 x2z1 x2y2 - - (False,False, False,False, - True, True, False,False) -> square x1y1 x1z1 x2z1 x2y1 - - (False,False, True, True, - False,False, False,False) -> square x1y2 x1z2 x2z2 x2y2 - - (False,False, False,False, - False,False, True, True ) -> square x1y1 x1z2 x2z2 x2y1 - - (False,False, True, True, - True, True, True, True ) -> square x1y2 x1z1 x2z1 x2y2 - - (True, True, True, True, - False,False, True, True ) -> square x1y1 x1z1 x2z1 x2y1 - - (True, True, False,False, - True, True, True, True ) -> square x1y2 x1z2 x2z2 x2y2 - - (True, True, True, True, - True, True, False,False) -> square x1y1 x1z2 x2z2 x2y1 - - -- lone points - - (True, False, False,False, - False,False, False,False) -> [(x1z1, y2z1, x1y2)] - - (False,True, False,False, - False,False, False,False) -> [(x2z1, y2z1, x2y2)] - - (False,False, False,False, - True, False, False,False) -> [(x1z1, y1z1, x1y1)] - - (False,False, False,False, - False,True, False,False) -> [(x2z1, y1z1, x2y1)] - - (False,False, True, False, - False,False, False,False) -> [(x1z2, y2z2, x1y2)] - - (False,False, False,True, - False,False, False,False) -> [(x2z2, y2z2, x2y2)] - - (False,False, False,False, - False,False, True, False) -> [(x1z2, y1z2, x1y1)] - - (False,False, False,False, - False,False, False,True ) -> [(x2z2, y1z2, x2y1)] - - (False,True, True, True, - True, True, True, True ) -> [(x1z1, y2z1, x1y2)] - - (True, False, True, True, - True, True, True, True ) -> [(x2z1, y2z1, x2y2)] - - (True, True, True, True, - False,True, True, True ) -> [(x1z1, y1z1, x1y1)] - - (True, True, True, True, - True, False, True, True ) -> [(x2z1, y1z1, x2y1)] - - (True, True, False,True, - True, True, True, True ) -> [(x1z2, y2z2, x1y2)] - - (True, True, True, False, - True, True, True, True ) -> [(x2z2, y2z2, x2y2)] - - (True, True, True, True, - True, True, False,True ) -> [(x1z2, y1z2, x1y1)] - - (True, True, True, True, - True, True, True, False) -> [(x2z2, y1z2, x2y1)] - - -- z flat + 1 - - (False,False, True, False, - False,False, True, True) -> [(x1y1,x2y1,x2z2), (x1y1,x2z2,y2z2), (x1y1,y2z2,x1y2)] - - (True, True, False,True, - True, True, False,False) -> [(x1y1,x2y1,x2z2), (x1y1,x2z2,y2z2), (x1y1,y2z2,x1y2)] - - (False,False, False,True, - False,False, True, True) -> [(x2y1,x1y1,x1z2), (x2y1,x1z2,y2z2), (x2y1,y2z2,x2y2)] - - (True, True, True, False, - True, True, False,False) -> [(x2y1,x1y1,x1z2), (x2y1,x1z2,y2z2), (x2y1,y2z2,x2y2)] - - (False,False, True, True, - False,False, True, False) -> [(x1y2,x2y2,x2z2), (x1y2,x2z2,y1z2), (x1y2,y1z2,x1y1)] - - (True, True, False,False, - True, True, False,True ) -> [(x1y2,x2y2,x2z2), (x1y2,x2z2,y1z2), (x1y2,y1z2,x1y1)] - - (False,False, True, True, - False,False, False,True) -> [(x2y2,x1y2,x1z2), (x2y2,x1z2,y1z2), (x2y2,y1z2,x2y1)] - - (True, True, False,False, - True, True, True, False) -> [(x2y2,x1y2,x1z2), (x2y2,x1z2,y1z2), (x2y2,y1z2,x2y1)] - - - - (True, False, False,False, - True, True, False,False) -> [(x1y1,x2y1,x2z1), (x1y1,x2z1,y2z1), (x1y1,y2z1,x1y2)] - - (False,True, True, True, - False,False, True, True) -> [(x1y1,x2y1,x2z1), (x1y1,x2z1,y2z1), (x1y1,y2z1,x1y2)] - - (False,True, False,False, - True, True, False,False) -> [(x2y1,x1y1,x1z1), (x2y1,x1z1,y2z1), (x2y1,y2z1,x2y2)] - - (True, False, True, True, - False,False, True, True) -> [(x2y1,x1y1,x1z1), (x2y1,x1z1,y2z1), (x2y1,y2z1,x2y2)] - - (True, True, False,False, - True, False, False,False) -> [(x1y2,x2y2,x2z1), (x1y2,x2z1,y1z1), (x1y2,y1z1,x1y1)] - - (False,False, True, True, - False,True, True, True) -> [(x1y2,x2y2,x2z1), (x1y2,x2z1,y1z1), (x1y2,y1z1,x1y1)] - - (True, True, False,False, - False,True, False,False) -> [(x2y2,x1y2,x1z1), (x2y2,x1z1,y1z1), (x2y2,y1z1,x2y1)] - - (False,False, True, True, - True, False, True, True) -> [(x2y2,x1y2,x1z1), (x2y2,x1z1,y1z1), (x2y2,y1z1,x2y1)] - - -- y flat + 1 - - (True, False, True, True, - True, False, True, False) -> [(y2z1,x2y2,x2z2),(y2z1,x2z2,y1z1),(y1z1,x2z2,y1z2)] - - (False,True, False,False, - False,True, False,True ) -> [(y2z1,x2y2,x2z2),(y2z1,x2z2,y1z1),(y1z1,x2z2,y1z2)] - - (True, False, True, False, - True, False, True, True ) -> [(y1z1,x2y1,x2z2),(y1z1,x2z2,y2z1),(y2z1,x2z2,y2z2)] - - (False,True, False,True, - False,True, False,False) -> [(y1z1,x2y1,x2z2),(y1z1,x2z2,y2z1),(y2z1,x2z2,y2z2)] - - (False,True, True, True, - False,True, False,True ) -> [(y2z1,x1y2,x1z2),(y2z1,x1z2,y1z1),(y1z1,x1z2,y1z2)] - - (True, False, False,False, - True, False, True, False) -> [(y2z1,x1y2,x1z2),(y2z1,x1z2,y1z1),(y1z1,x1z2,y1z2)] - - (False,True, False,True, - False,True, True, True ) -> [(y1z1,x1y1,x1z2),(y1z1,x1z2,y2z1),(y2z1,x1z2,y2z2)] - - (True, False, True, False, - True, False, False,False) -> [(y1z1,x1y1,x1z2),(y1z1,x1z2,y2z1),(y2z1,x1z2,y2z2)] - - - - (True, True, True, False, - True, False, True, False) -> [(y2z2,x2y2,x2z1),(y2z2,x2z1,y1z2),(y1z2,x2z1,y1z1)] - - (False,False, False,True, - False,True, False,True ) -> [(y2z2,x2y2,x2z1),(y2z2,x2z1,y1z2),(y1z2,x2z1,y1z1)] - - (True, False, True, False, - True, True, True, False) -> [(y1z2,x2y1,x2z1),(y1z2,x2z1,y2z2),(y2z2,x2z1,y2z1)] - - (False,True, False,True, - False,False, False,True) -> [(y1z2,x2y1,x2z1),(y1z2,x2z1,y2z2),(y2z2,x2z1,y2z1)] - - (True, True, False,True, - False,True, False,True) -> [(y2z2,x1y2,x1z1),(y2z2,x1z1,y1z2),(y1z2,x1z1,y1z1)] - - (False,False, True, False, - True, False, True, False) -> [(y2z2,x1y2,x1z1),(y2z2,x1z1,y1z2),(y1z2,x1z1,y1z1)] - - (False,True, False,True, - True, True, False,True) -> [(y1z2,x1y1,x1z1),(y1z2,x1z1,y2z2),(y2z2,x1z1,y2z1)] - - (True, False, True, False, - False,False, True, False) -> [(y1z2,x1y1,x1z1),(y1z2,x1z1,y2z2),(y2z2,x1z1,y2z1)] - - - - -- x flat +1 - - (True, True, True, True, - False,False, True, False) -> [(x1z1,x2z1,x1y1),(x1y1,x2z1,x2z2),(x1y1,x2z2,y1z2)] - - (False,False, False,False, - True, True, False,True ) -> [(x1z1,x2z1,x1y1),(x1y1,x2z1,x2z2),(x1y1,x2z2,y1z2)] - - (False,False, True, False, - True, True, True, True) -> [(x1z1,x2z1,x1y2),(x1y2,x2z1,x2z2),(x1y2,x2z2,y2z2)] - - (True, True, False,True, - False,False, False,False) -> [(x1z1,x2z1,x1y2),(x1y2,x2z1,x2z2),(x1y2,x2z2,y2z2)] - - (True, True, True, True, - False,False, False,True) -> [(x2z1,x1z1,x2y1),(x2y1,x1z1,x1z2),(x2y1,x1z2,y1z2)] - - (False,False, False,False, - True, True, True, False) -> [(x2z1,x1z1,x2y1),(x2y1,x1z1,x1z2),(x2y1,x1z2,y1z2)] - - (False,False, False,True, - True, True, True, True) -> [(x2z1,x1z1,x2y2),(x2y2,x1z1,x1z2),(x2y2,x1z2,y2z2)] - - (True, True, True, False, - False,False, False,False) -> [(x2z1,x1z1,x2y2),(x2y2,x1z1,x1z2),(x2y2,x1z2,y2z2)] - - - (True, True, True, True, - True, False, False,False) -> [(x1z2,x2z2,x1y1),(x1y1,x2z2,x2z1),(x1y1,x2z1,y1z1)] - - (False,False, False,False, - False,True, True, True ) -> [(x1z2,x2z2,x1y1),(x1y1,x2z2,x2z1),(x1y1,x2z1,y1z1)] - - (True, False, False,False, - True, True, True, True ) -> [(x1z2,x2z2,x1y2),(x1y2,x2z2,x2z1),(x1y2,x2z1,y2z1)] - - (False,True, True, True, - False,False, False,False) -> [(x1z2,x2z2,x1y2),(x1y2,x2z2,x2z1),(x1y2,x2z1,y2z1)] - - (True, True, True, True, - False,True, False,False) -> [(x2z2,x1z2,x2y1),(x2y1,x1z2,x1z1),(x2y1,x1z1,y1z1)] - - (False,False, False,False, - True, False, True, True) -> [(x2z2,x1z2,x2y1),(x2y1,x1z2,x1z1),(x2y1,x1z1,y1z1)] - - (False,True, False,False, - True, True, True, True) -> [(x2z2,x1z2,x2y2),(x2y2,x1z2,x1z1),(x2y2,x1z1,y2z1)] - - (True, False, True, True, - False,False, False,False) -> [(x2z2,x1z2,x2y2),(x2y2,x1z2,x1z1),(x2y2,x1z1,y2z1)] - - - - (True, True, True, False, - True, False, False,False) -> [(x1y1,x1z2,y1z1),(y1z1,x1z2,y2z2),(y1z1,y2z2,x2z1),(x2z1,y2z2,x2y2)] - - (False,False, False,True, - False,True, True, True ) -> [(x1y1,x1z2,y1z1),(y1z1,x1z2,y2z2),(y1z1,y2z2,x2z1),(x2z1,y2z2,x2y2)] - - (True, True, False,True, - False,True, False,False) -> [(x2y1,x2z2,y1z1),(y1z1,x2z2,y2z2),(y1z1,y2z2,x1z1),(x1z1,y2z2,x1y2)] - - (False,False, True, False, - True, False, True, True ) -> [(x2y1,x2z2,y1z1),(y1z1,x2z2,y2z2),(y1z1,y2z2,x1z1),(x1z1,y2z2,x1y2)] - - - - - (True, False, False,False, - True, True, True, False) -> [(x1y2,x1z2,y2z1),(y2z1,x1z2,y1z2),(y2z1,y1z2,x2z1),(x2z1,y1z2,x2y1)] - - (False,True, True, True, - False,False, False,True ) -> [(x1y2,x1z2,y2z1),(y2z1,x1z2,y1z2),(y2z1,y1z2,x2z1),(x2z1,y1z2,x2y1)] - - (False,True, False,False, - True, True, False,True ) -> [(x2y2,x2z2,y2z1),(y2z1,x2z2,y1z2),(y2z1,y1z2,x1z1),(x1z1,y1z2,x1y1)] - - (True, False, True, True, - False,False, True, False) -> [(x2y2,x2z2,y2z1),(y2z1,x2z2,y1z2),(y2z1,y1z2,x1z1),(x1z1,y1z2,x1y1)] - - - - - _ -> [] - diff --git a/extopenscad.hs b/extopenscad.hs new file mode 100644 --- /dev/null +++ b/extopenscad.hs @@ -0,0 +1,52 @@ +-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) +-- Released under the GNU GPL, see LICENSE + +-- 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 (getArgs) +import System.IO (openFile, IOMode (ReadMode), hGetContents, hClose) +import Graphics.Implicit (runOpenscad, writeSVG, writeSTL) +import Graphics.Implicit.ExtOpenScad.Definitions (OpenscadObj (ONum)) +import Data.Map as Map + +-- | strip a .scad or .escad file to its basename. +strip :: String -> String +strip filename = case reverse filename of + 'd':'a':'c':'s':'.':xs -> reverse xs + 'd':'a':'c':'s':'e':'.':xs -> reverse xs + _ -> filename + +-- | Give an openscad object to run and the basename of +-- the target to write to... write an object! +executeAndExport :: String -> String -> IO () +executeAndExport content targetname = case runOpenscad content of + Left err -> putStrLn $ show $ err + Right openscadProgram -> do + s@(vars, obj2s, obj3s) <- openscadProgram + let { + res = case Map.lookup "$res" vars of + Nothing -> 1 + Just (ONum n) -> n + Just (_) -> 1 + } in case s of + (_, [], []) -> putStrLn "Nothing to render" + (_, x:xs, []) -> do + putStrLn $ "Rendering 2D object to " ++ targetname ++ ".svg" + writeSVG res (targetname ++ ".svg") x + (_, _, x:xs) -> do + putStrLn $ "Rendering 3D object to " ++ targetname++ ".stl" + writeSTL res (targetname ++ ".stl") x + + +main :: IO() +main = do + args <- getArgs + case length args of + 0 -> putStrLn "syntax: extopenscad file.escad" + _ -> do + f <- openFile (args !! 0) ReadMode + content <- hGetContents f + executeAndExport content (strip $ args !! 0) + hClose f + diff --git a/implicit.cabal b/implicit.cabal --- a/implicit.cabal +++ b/implicit.cabal @@ -1,5 +1,5 @@ Name: implicit -Version: 0.0.0 +Version: 0.0.1 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. @@ -15,19 +15,64 @@ Category: Graphics Library - Build-Depends: base >= 3 && < 5, parsec, hashmap, parallel, containers + Build-Depends: base >= 3 && < 5, parsec, hashmap, parallel, containers, haskell98 + ghc-options: -O2 + Extensions: MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances Exposed-Modules: Graphics.Implicit Graphics.Implicit.Definitions Graphics.Implicit.Export - Graphics.Implicit.ExtOpenScad Graphics.Implicit.MathUtil Graphics.Implicit.Operations - Graphics.Implicit.Primitives Graphics.Implicit.SaneOperators - Graphics.Implicit.Tracing - Graphics.Implicit.Tracing.GetTriangles + Other-Modules: + Graphics.Implicit.Primitives + Graphics.Implicit.Primitives.Definitions + Graphics.Implicit.Primitives.BoxedObj2 + Graphics.Implicit.Primitives.BoxedObj3 + Graphics.Implicit.Primitives.SymbolicObj2 + Graphics.Implicit.Primitives.SymbolicObj3 + Graphics.Implicit.Primitives.Obj2 + Graphics.Implicit.Primitives.Obj3 + Graphics.Implicit.Operations.Definitions + Graphics.Implicit.Operations.Box2 + Graphics.Implicit.Operations.Box3 + Graphics.Implicit.Operations.BoxPair + Graphics.Implicit.Operations.BoxedObj2 + Graphics.Implicit.Operations.BoxedObj3 + Graphics.Implicit.Operations.BoxedObjPair + Graphics.Implicit.Operations.SymbolicObj2 + Graphics.Implicit.Operations.SymbolicObj3 + Graphics.Implicit.Operations.SymbolicObjPair + Graphics.Implicit.Operations.Obj2 + Graphics.Implicit.Operations.Obj3 + Graphics.Implicit.Operations.ObjPair + Graphics.Implicit.ExtOpenScad + Graphics.Implicit.ExtOpenScad.Definitions + Graphics.Implicit.ExtOpenScad.Default + Graphics.Implicit.ExtOpenScad.Expressions + Graphics.Implicit.ExtOpenScad.Primitives + Graphics.Implicit.ExtOpenScad.Statements + Graphics.Implicit.ExtOpenScad.Util + Graphics.Implicit.Export.Definitions + Graphics.Implicit.Export.MarchingSquares + Graphics.Implicit.Export.MarchingSquaresFill + Graphics.Implicit.Export.MarchingCubes + Graphics.Implicit.Export.BoxedObj2 + Graphics.Implicit.Export.BoxedObj3 + Graphics.Implicit.Export.SymbolicObj2 + Graphics.Implicit.Export.SymbolicObj3 + Graphics.Implicit.Export.PolylineFormats + Graphics.Implicit.Export.TriangleMeshFormats + Graphics.Implicit.Export.Util + Graphics.Implicit.Export.Symbolic.CoerceSymbolic2 + Graphics.Implicit.Export.Symbolic.CoerceSymbolic3 + Graphics.Implicit.Export.Symbolic.Rebound2 + Graphics.Implicit.Export.Symbolic.Rebound3 +Executable extopenscad + + Main-is: extopenscad.hs source-repository head type: git location: https://github.com/colah/ImplicitCAD.git