packages feed

implicit 0.0.0 → 0.0.1

raw patch · 52 files changed

+3551/−1040 lines, 52 filesdep +haskell98dep ~basenew-component:exe:extopenscad

Dependencies added: haskell98

Dependency ranges changed: base

Files

Graphics/Implicit.hs view
@@ -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
Graphics/Implicit/Definitions.hs view
@@ -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 = "<function>"
Graphics/Implicit/Export.hs view
@@ -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 -> -				"  <polyline points=\"" -				++ concat (map (\(x,y) -> " " ++ show x ++ "," ++ show y) line)-				++ "\" style=\"stroke:rgb(0,0,255);stroke-width:1;fill:none;\"/> \n" ) -				multilines	-		text = "<svg xmlns=\"http://www.w3.org/2000/svg\" version=\"1.1\"> \n" -			++ svglines			-			++ "</svg> "-	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 -> -				"  <polyline points=\"" -				++ concat (map (\(x,y) -> " " ++ show x ++ "," ++ show y) line)-				++ "\" style=\"stroke:rgb(0,0,255);stroke-width:1;fill:none;\"/> \n" ) -				multilines	-		text = "<svg xmlns=\"http://www.w3.org/2000/svg\" version=\"1.1\"> \n" -			++ svglines			-			++ "</svg> "-	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-+-}+-}
+ Graphics/Implicit/Export/BoxedObj2.hs view
@@ -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
+ Graphics/Implicit/Export/BoxedObj3.hs view
@@ -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
+ Graphics/Implicit/Export/Definitions.hs view
@@ -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++
+ Graphics/Implicit/Export/MarchingCubes.hs view
@@ -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)]+++++		_ -> []+
+ Graphics/Implicit/Export/MarchingSquares.hs view
@@ -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+
+ Graphics/Implicit/Export/MarchingSquaresFill.hs view
@@ -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]]+++
+ Graphics/Implicit/Export/PolylineFormats.hs view
@@ -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 -> +				"  <polyline points=\"" +				++ concat (map (\(x,y) -> " " ++ show x ++ "," ++ show y) line)+				++ "\" style=\"stroke:rgb(0,0,255);stroke-width:1;fill:none;\"/> \n" ) +				polylines2	+		text = "<svg xmlns=\"http://www.w3.org/2000/svg\" version=\"1.1\"> \n" +			++ svglines		+			++ "</svg> "++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+
+ Graphics/Implicit/Export/Symbolic/CoerceSymbolic2.hs view
@@ -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+
+ Graphics/Implicit/Export/Symbolic/CoerceSymbolic3.hs view
@@ -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)+
+ Graphics/Implicit/Export/Symbolic/Rebound2.hs view
@@ -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)))
+ Graphics/Implicit/Export/Symbolic/Rebound3.hs view
@@ -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)))+
+ Graphics/Implicit/Export/SymbolicObj2.hs view
@@ -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++
+ Graphics/Implicit/Export/SymbolicObj3.hs view
@@ -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 +
+ Graphics/Implicit/Export/TriangleMeshFormats.hs view
@@ -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+
+ Graphics/Implicit/Export/Util.hs view
@@ -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]+++
Graphics/Implicit/ExtOpenScad.hs view
@@ -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) = "<function>"--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
+ Graphics/Implicit/ExtOpenScad/Default.hs view
@@ -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++
+ Graphics/Implicit/ExtOpenScad/Definitions.hs view
@@ -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) = "<function>"++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
+ Graphics/Implicit/ExtOpenScad/Expressions.hs view
@@ -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)+
+ Graphics/Implicit/ExtOpenScad/Primitives.hs view
@@ -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;+++
+ Graphics/Implicit/ExtOpenScad/Statements.hs view
@@ -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)+
+ Graphics/Implicit/ExtOpenScad/Util.hs view
@@ -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++
Graphics/Implicit/Operations.hs view
@@ -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)  ++-}
+ Graphics/Implicit/Operations/Box2.hs view
@@ -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
+ Graphics/Implicit/Operations/Box3.hs view
@@ -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
+ Graphics/Implicit/Operations/BoxPair.hs view
@@ -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]+
+ Graphics/Implicit/Operations/BoxedObj2.hs view
@@ -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
+ Graphics/Implicit/Operations/BoxedObj3.hs view
@@ -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
+ Graphics/Implicit/Operations/BoxedObjPair.hs view
@@ -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)
+ Graphics/Implicit/Operations/Definitions.hs view
@@ -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+
+ Graphics/Implicit/Operations/Obj2.hs view
@@ -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)
+ Graphics/Implicit/Operations/Obj3.hs view
@@ -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)
+ Graphics/Implicit/Operations/ObjPair.hs view
@@ -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+
+ Graphics/Implicit/Operations/SymbolicObj2.hs view
@@ -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
+ Graphics/Implicit/Operations/SymbolicObj3.hs view
@@ -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
+ Graphics/Implicit/Operations/SymbolicObjPair.hs view
@@ -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+
Graphics/Implicit/Primitives.hs view
@@ -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
+ Graphics/Implicit/Primitives/BoxedObj2.hs view
@@ -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++
+ Graphics/Implicit/Primitives/BoxedObj3.hs view
@@ -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++
+ Graphics/Implicit/Primitives/Definitions.hs view
@@ -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++++
+ Graphics/Implicit/Primitives/Obj2.hs view
@@ -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)+
+ Graphics/Implicit/Primitives/Obj3.hs view
@@ -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)+
+ Graphics/Implicit/Primitives/SymbolicObj2.hs view
@@ -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+
+ Graphics/Implicit/Primitives/SymbolicObj3.hs view
@@ -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++
Graphics/Implicit/SaneOperators.hs view
@@ -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)
− Graphics/Implicit/Tracing.hs 
@@ -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-}-
− Graphics/Implicit/Tracing/GetTriangles.hs 
@@ -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)]-----		_ -> []-
+ extopenscad.hs view
@@ -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+
implicit.cabal view
@@ -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