packages feed

implicit 0.0.1 → 0.0.2

raw patch · 65 files changed

+3290/−2148 lines, 65 filesdep +deepseqdep +pluginsdep −haskell98dep ~base

Dependencies added: deepseq, plugins

Dependencies removed: haskell98

Dependency ranges changed: base

Files

Graphics/Implicit.hs view
@@ -22,6 +22,7 @@ 	rect3R, 	circle, 	cylinder,+	cylinder2, 	rectR, 	--regularPolygon, 	--zsurface,@@ -29,116 +30,17 @@ 	-- Export 	writeSVG, 	writeSTL,+	writeOBJ,+	writeTHREEJS,+	writeSCAD2,+	writeSCAD3,+	writeGCodeHacklabLaser, 	runOpenscad ) where  -- 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.Primitives 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--------+import Graphics.Implicit.Export --- 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
@@ -3,6 +3,11 @@  module Graphics.Implicit.Definitions where +-- a few imports for great evil :(+-- we want global IO refs.+import Data.IORef (IORef, newIORef, readIORef)+import System.IO.Unsafe (unsafePerformIO)+ -- Let's make things a bit nicer.  -- Following math notation ℝ, ℝ², ℝ³... type ℝ = Float@@ -11,6 +16,12 @@  type ℕ = Int +-- nxn matrices+-- eg. M2 ℝ = M₂(ℝ)+type M2 a = ((a,a),(a,a))+type M3 a = ((a,a,a),(a,a,a),(a,a,a))++ -- | A chain of line segments, as in SVG -- eg. [(0,0), (0.5,1), (1,0)] ---> /\ type Polyline = [ℝ2]@@ -18,9 +29,17 @@ -- | A triangle (a,b,c) = a trinagle with vertices a, b and c type Triangle = (ℝ3, ℝ3, ℝ3) +-- | A triangle ((v1,n1),(v2,n2),(v3,n3)) has vertices v1, v2, v3+--   with corresponding normals n1, n2, and n3+type NormedTriangle = ((ℝ3, ℝ3), (ℝ3, ℝ3), (ℝ3, ℝ3))++ -- | A triangle mesh is a bunch of triangles :) type TriangleMesh = [Triangle] +-- | A normed triangle mesh is a bunch of normed trianlges!!+type NormedTriangleMesh = [NormedTriangle]+ -- $ 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@@ -64,7 +83,7 @@ 	| IntersectR2 ℝ [SymbolicObj2] 	-- Simple transforms 	| Translate2 ℝ2 SymbolicObj2-	| Scale2 ℝ SymbolicObj2+	| Scale2 ℝ2 SymbolicObj2 	| Rotate2 ℝ SymbolicObj2 	-- Boundary mods 	| Outset2 ℝ SymbolicObj2@@ -76,19 +95,20 @@ -- | A symbolic 3D format!  data SymbolicObj3 = -	-- Some simple primitives+	-- Primitives 	  Rect3R ℝ ℝ3 ℝ3 	| Sphere ℝ-	-- Some (rounded) CSG+	| Cylinder ℝ ℝ ℝ -- h r1 r2+	-- (Rounded) CSG 	| Complement3 SymbolicObj3 	| UnionR3 ℝ [SymbolicObj3] 	| IntersectR3 ℝ [SymbolicObj3] 	| DifferenceR3 ℝ [SymbolicObj3]-	-- Some simple transofrms+	-- Simple transforms 	| Translate3 ℝ3 SymbolicObj3-	| Scale3 ℝ SymbolicObj3+	| Scale3 ℝ3 SymbolicObj3 	| Rotate3 (ℝ,ℝ,ℝ) SymbolicObj3-	-- Some boundary based transforms+	-- Boundary mods 	| Outset3 ℝ SymbolicObj3 	| Shell3 ℝ SymbolicObj3 	-- Misc@@ -96,18 +116,51 @@ 	-- 2D based 	| ExtrudeR ℝ SymbolicObj2 ℝ 	| ExtrudeRotateR ℝ ℝ SymbolicObj2 ℝ-	| ExtrudeRMod ℝ (ℝ -> ℝ2 -> ℝ2) SymbolicObj2 ℝ+	| ExtrudeRM +		ℝ                 -- ^ rounding radius+		(Maybe (ℝ -> ℝ))  -- ^ twist+		(Maybe (ℝ -> ℝ))  -- ^ scale+		(Maybe (ℝ -> ℝ2)) -- ^ translate+		SymbolicObj2      -- ^ object to extrude+		(Either ℝ (ℝ2 -> ℝ)) -- ^ height to extrude to 	| ExtrudeOnEdgeOf SymbolicObj2 SymbolicObj2 	deriving Show --- | Rectiliniar 2D set-type Rectiliniar2 = [Box2]+-- | Rectilinear 2D set+type Rectilinear2 = [Box2] --- | Rectiliniar 2D set-type Rectiliniar3 = [Box3]+-- | Rectilinear 2D set+type Rectilinear3 = [Box3]  -- | Make ALL the functions Showable! --   This is very handy when testing functions in interactive mode... instance Show (a -> b) where 	show f = "<function>" +-- | Now for something that makes me a bad person...+--   I promise I'll use it for good, not evil!+--   I don't want to reparse the program arguments +--   everytime I want to know if XML errors are needed.++{-# NOINLINE xmlErrorOn #-}++xmlErrorOn :: IORef Bool+xmlErrorOn = unsafePerformIO $ newIORef False++errorMessage :: Int -> String -> IO()+errorMessage line msg = do+		useXML <- readIORef xmlErrorOn+		let+			msg' = "At line <line>" ++ show line ++ "</line>:" ++ msg+			-- dropXML inTag (x:xs)+			dropXML inQuote False ('"':xs) = '"':dropXML (not inQuote) False  xs+			dropXML True    _     ( x :xs) = x:dropXML True    False  xs+			dropXML False   False ('<':xs) =   dropXML False   True  xs+			dropXML False   True  ('>':xs) =   dropXML False   False xs+			dropXML inQuote True  ( _ :xs) =   dropXML inQuote True  xs+			dropXML inQuote False ( x :xs) = x:dropXML inQuote False xs+			dropXML _       _        []    = []+		if useXML +			then putStrLn $ "<error>" ++ msg' ++ "</error>"+			else putStrLn $ dropXML False False $ msg'+		return ()
Graphics/Implicit/Export.hs view
@@ -12,14 +12,14 @@ 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+import qualified Graphics.Implicit.Export.NormedTriangleMeshFormats as NormedTriangleMeshFormats+import qualified Graphics.Implicit.Export.SymbolicFormats as SymbolicFormats  -- Write an object in a given formet... @@ -40,9 +40,13 @@ writeSVG res = writeObject res PolylineFormats.svg  writeSTL res = writeObject res  TriangleMeshFormats.stl+writeOBJ res = writeObject res  NormedTriangleMeshFormats.obj+writeTHREEJS res = writeObject res  TriangleMeshFormats.jsTHREE  writeGCodeHacklabLaser res = writeObject res PolylineFormats.hacklabLaserGCode +writeSCAD3 res filename obj = writeFile filename (SymbolicFormats.scad3 res obj)+writeSCAD2 res filename obj = writeFile filename (SymbolicFormats.scad2 res obj)   {-
− Graphics/Implicit/Export/BoxedObj2.hs 
@@ -1,14 +0,0 @@--- 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 
@@ -1,12 +0,0 @@--{-# 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
@@ -8,7 +8,7 @@ -- | 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+class DiscreteAproxable obj aprox where 	discreteAprox :: ℝ -> obj -> aprox
− Graphics/Implicit/Export/MarchingCubes.hs 
@@ -1,510 +0,0 @@--- 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
@@ -4,7 +4,8 @@ module Graphics.Implicit.Export.MarchingSquares (getContour) where  import Graphics.Implicit.Definitions-import Control.Parallel (par, pseq)+import Control.Parallel.Strategies (using, parList, rdeepseq)+import Debug.Trace  -- | getContour gets a polyline describe the edge of your 2D --  object. It's really the only function in this file you need@@ -25,9 +26,34 @@ 		     | 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+		multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLinesDC $ linesOnGrid 	in 		multilines++getContour2 :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [Polyline]+getContour2 (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+		-- Grid mapping funcs+		fromGrid (mx, my) = (x1 + (x2 - x1)*mx/nx, y1 + (y2 - y1)*my/ny)+		toGrid (x,y) =(\a-> traceShow a a) (floor $ nx*(x-x1)/(x2-x1), floor $ ny*(y-y1)/(y2-y1) ) :: (ℕ, ℕ)+		-- Evalueate obj on a grid, in parallel.+		valsOnGrid :: [[ℝ]]+		valsOnGrid = [[ obj (fromGrid (mx, my)) | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]+		              `using` parList rdeepseq+		-- A faster version of the obj. Sort of like memoization, but done in advance, in parallel.+		preEvaledObj p = valsOnGrid !! my !! mx where (mx,my) = toGrid p+		-- Divide it up and compute the polylines+		linesOnGrid :: [[[Polyline]]]+		linesOnGrid = [[getSquareLineSegs (fromGrid (mx, my)) (fromGrid (mx+1, my+1)) preEvaledObj+		     | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]+		-- Cleanup, cleanup, everybody cleanup!+		-- (We connect multilines, delete redundant vertices on them, etc)+		multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLinesDC $ linesOnGrid+	in+		multilines 		  -- | This function gives line segmensts to divde negative interior@@ -139,11 +165,13 @@ 	if (x1,y1) == (x2,y2) then reducePolyline ((x2,y2):others) else (x1,y1):(x2,y2):others reducePolyline l = l + orderLinesDC :: [[[Polyline]]] -> [Polyline] orderLinesDC segs = 	let+		halve :: [a] -> ([a], [a]) 		halve l = splitAt (div (length l) 2) l-		splitOrder segs = case (\(x,y) -> (halve x, halve y)) $ unzip $ map (halve) segs of+		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@@ -151,6 +179,7 @@ 			((a,b),(c,d)) ->orderLines $  				orderLinesDC a ++ orderLinesDC b ++ orderLinesDC c ++ orderLinesDC d +{- orderLinesP :: [[[Polyline]]] -> [Polyline] orderLinesP segs = 	let@@ -172,6 +201,7 @@ 					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)
+ Graphics/Implicit/Export/NormedTriangleMeshFormats.hs view
@@ -0,0 +1,40 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++module Graphics.Implicit.Export.NormedTriangleMeshFormats where++import Graphics.Implicit.Definitions++obj normedtriangles = text+	where+		-- A vertex line; v (0.0, 0.0, 1.0) = "v 0.0 0.0 1.0\n"+		v :: ℝ3 -> String+		v (x,y,z) = "v "  ++ show x ++ " " ++ show y ++ " " ++ show z ++ "\n"+		-- A normal line; n (0.0, 0.0, 1.0) = "vn 0.0 0.0 1.0\n"+		n :: ℝ3 -> String+		n (x,y,z) = "vn " ++ show x ++ " " ++ show y ++ " " ++ show z ++ "\n"+		verts = do+			-- extract the vertices for each triangle+			-- recall that a normed triangle is of the form ((vert, norm), ...)+			((a,_),(b,_),(c,_)) <- normedtriangles+			-- The vertices from each triangle take up 3 position in the resulting list+			[a,b,c]+		norms = do+			-- extract the normals for each triangle+			((_,a),(_,b),(_,c)) <- normedtriangles+			-- The normals from each triangle take up 3 position in the resulting list+			[a,b,c]+		vertcode = concat $ map v verts+		normcode = concat $ map n norms+		trianglecode = concat $ do+			n <- map ((+1).(*3)) [0,1 .. length normedtriangles -1]+			let+				vta = show  n   -- ++ "//" ++ show  n+				vtb = show (n+1)-- ++ "//" ++ show (n+1)+				vtc = show (n+2)-- ++ "//" ++ show (n+2)+			return $ "f " ++ vta ++ " " ++ vtb ++ " " ++ vtc ++ " " ++ "\n"+		text = vertcode ++ normcode ++ trianglecode++++
Graphics/Implicit/Export/PolylineFormats.hs view
@@ -6,6 +6,9 @@  import Graphics.Implicit.Definitions +import Text.Printf (printf)++svg :: [Polyline] -> String svg polylines = text 	where 		-- SVG is stupidly laid out... (0,0) is the top left corner@@ -22,6 +25,7 @@ 			++ svglines		 			++ "</svg> " +hacklabLaserGCode :: [Polyline] -> String hacklabLaserGCode polylines = text 	where 		gcodeHeader = @@ -36,8 +40,9 @@ 			"M5 (disable laser)\n" 			++"G00 X0.0 Y0.0 (move to 0)\n" 			++"M2 (end)"+		showF n = printf "%.4f" n 		gcodeXY :: ℝ2 -> [Char]-		gcodeXY (x,y) = "X"++ show x ++" Y"++ show y +		gcodeXY (x,y) = "X"++ showF x ++" Y"++ showF y  		interpretPolyline (start:others) =  			"G00 "++ gcodeXY start ++ "\n" 			++ "M62 P0 (laser on)\n"
+ Graphics/Implicit/Export/Render.hs view
@@ -0,0 +1,264 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++{-# LANGUAGE ParallelListComp #-}++module Graphics.Implicit.Export.Render where++import Debug.Trace++import Graphics.Implicit.Definitions+import Graphics.Implicit.Export.Render.Definitions++-- Here's the plan for rendering a cube (the 2D case is trivial):++-- (1) We calculate midpoints using interpolate.+--     This guarentees that our mesh will line up everywhere.+--     (Contrast with calculating them in getSegs)++import Graphics.Implicit.Export.Render.Interpolate (interpolate)++-- (2) We calculate the segments separating the inside and outside of our+--     object on the sides of the cube.+--     getSegs internally uses refine from RefineSegs to subdivide the segs+--     to better match the boundary.++import Graphics.Implicit.Export.Render.GetSegs (getSegs, getSegs')+-- import Graphics.Implicit.Export.Render.RefineSegs (refine)++-- (3) We put the segments from all sides of the cube together+--     and extract closed loops.++import Graphics.Implicit.Export.Render.GetLoops (getLoops)++-- (4) We tesselate the loops, using a mixtur of triangles and squares++import Graphics.Implicit.Export.Render.TesselateLoops (tesselateLoop)++-- (5) We try to merge squares, then turn everything into triangles.++import Graphics.Implicit.Export.Render.HandleSquares (mergedSquareTris)++-- Success: This is our mesh.++-- Each step is done in parallel using Control.Parallel.Strategies++import Control.Parallel.Strategies (using, rdeepseq, parListChunk)++-- The actual code is just a bunch of ugly argument passing.+-- Utility functions can be found at the end.++getMesh :: ℝ3 -> ℝ3 -> ℝ -> Obj3 -> TriangleMesh+getMesh (x1, y1, z1) (x2, y2, z2) res obj = +	let+		dx = x2-x1+		dy = y2-y1+		dz = z2-z1++		-- How many steps will we take on each axis?+		nx = ceiling $ dx / res+		ny = ceiling $ dy / res+		nz = ceiling $ dz / res++		rx = dx/fromIntegral nx+		ry = dy/fromIntegral ny+		rz = dz/fromIntegral nz++		l ! (a,b,c) = l !! c !! b !! a++		pZs = [ z1 + rz*n | n <- [0.. fromIntegral nz] ]+		pYs = [ y1 + ry*n | n <- [0.. fromIntegral ny] ]+		pXs = [ x1 + rx*n | n <- [0.. fromIntegral nx] ]+++		{-# INLINE par3DList #-}+		par3DList lenx leny lenz f = +			[[[f +				(\n -> x1 + rx*fromIntegral (mx+n)) mx +				(\n -> y1 + ry*fromIntegral (my+n)) my +				(\n -> z1 + rz*fromIntegral (mz+n)) mz+			| mx <- [0..lenx] ] | my <- [0..leny] ] | mz <- [0..lenz] ] +				`using` (parListChunk (max 1 $ div lenz 32) rdeepseq)+++		-- Evaluate obj to avoid waste in mids, segs, later.++		objV = par3DList (nx+2) (ny+2) (nz+2) $ \x _ y _ z _ -> obj (x 0, y 0, z 0)++		-- (1) Calculate mid poinsts on X, Y, and Z axis in 3D space.++		midsZ = [[[+				 interpolate (z0, objX0Y0Z0) (z1, objX0Y0Z1) (appAB obj x0 y0) res+				 | x0 <- pXs |                  objX0Y0Z0 <- objY0Z0 | objX0Y0Z1 <- objY0Z1+				]| y0 <- pYs |                  objY0Z0 <- objZ0 | objY0Z1 <- objZ1+				]| z0 <- pZs | z1 <- tail pZs | objZ0   <- objV  | objZ1   <- tail objV+				] `using` (parListChunk (max 1 $ div nz 32) rdeepseq)++		midsY = [[[+				 interpolate (y0, objX0Y0Z0) (y1, objX0Y1Z0) (appAC obj x0 z0) res+				 | x0 <- pXs |                  objX0Y0Z0 <- objY0Z0 | objX0Y1Z0 <- objY1Z0+				]| y0 <- pYs | y1 <- tail pYs | objY0Z0 <- objZ0 | objY1Z0 <- tail objZ0+				]| z0 <- pZs |                  objZ0   <- objV +				] `using` (parListChunk (max 1 $ div nz 32) rdeepseq)++		midsX = [[[+				 interpolate (x0, objX0Y0Z0) (x1, objX1Y0Z0) (appBC obj y0 z0) res+				 | x0 <- pXs | x1 <- tail pXs | objX0Y0Z0 <- objY0Z0 | objX1Y0Z0 <- tail objY0Z0+				]| y0 <- pYs |                  objY0Z0 <- objZ0 +				]| z0 <- pZs |                  objZ0   <- objV +				] `using` (parListChunk (max 1 $ div nz 32) rdeepseq)++		-- Calculate segments for each side++		segsZ = [[[ +			map2  (inj3 z0) $ getSegs (x0,y0) (x1,y1) (obj **$ z0)+			    (objX0Y0Z0, objX1Y0Z0, objX0Y1Z0, objX1Y1Z0)+			    (midA0, midA1, midB0, midB1)+			 |x0<-pXs|x1<-tail pXs|midB0<-mX'' |midB1<-mX'T    |midA0<-mY'' |midA1<-tail mY''+			 |objX0Y0Z0<-objY0Z0|objX1Y0Z0<-tail objY0Z0|objX0Y1Z0<-objY1Z0|objX1Y1Z0<-tail objY1Z0+			]|y0<-pYs|y1<-tail pYs|mX'' <-mX'  |mX'T <-tail mX'|mY'' <-mY'+			 |objY0Z0 <- objZ0 | objY1Z0 <- tail objZ0+			]|z0<-pZs             |mX'  <-midsX|                mY'  <-midsY+			 |objZ0 <- objV+			] `using` (parListChunk (max 1 $ div nz 32) rdeepseq) -- -}+			{-let+				iteree = zip3D3 (lag3 points) (lag3s22 midsY) (lag3s12 midsX)+				transform (((x0,y0,z0),(x1,y1,z1)), (midA0,midA1), (midB0,midB1)) =+					map2  (inj3 z0) $ +						getSegs (x0,y0) (x1,y1) (obj **$ z0) (midA0, midA1, midB0, midB1)+				result = for3 iteree transform+			in+				result --`using` (parListChunk (max 1 $ div lenz 32) rdeepseq)-}+		  {-par3DList (nx-1) (ny-1) (nz) $ \x mx y my z mz ->+		       map2  (inj3 (z 0)) $ getSegs'+		           (x 0, y 0)+                   (x 1, y 1)+                   (obj **$ z 0)+		           (midsY ! (mx, my, mz), midsY ! (mx+1, my, mz),+		            midsX ! (mx, my, mz), midsX ! (mx, my+1, mz)) -- -}+		segsY = [[[ +			map2  (inj2 y0) $ getSegs (x0,z0) (x1,z1) (obj *$* y0) +			     (objX0Y0Z0,objX1Y0Z0,objX0Y0Z1,objX1Y0Z1)+			     (midA0, midA1, midB0, midB1)+			 |x0<-pXs|x1<-tail pXs|midB0<-mB'' |midB1<-mBT'      |midA0<-mA'' |midA1<-tail mA''+			 |objX0Y0Z0<-objY0Z0|objX1Y0Z0<-tail objY0Z0|objX0Y0Z1<-objY0Z1|objX1Y0Z1<-tail objY0Z1+			]|y0<-pYs|             mB'' <-mB'  |mBT' <-mBT       |mA'' <-mA'+			 |objY0Z0 <- objZ0 | objY0Z1 <- objZ1+			]|z0<-pZs|z1<-tail pZs|mB'  <-midsX|mBT  <-tail midsX|mA'  <-midsZ +			 |objZ0 <- objV | objZ1 <- tail objV+			] `using` (parListChunk (max 1 $ div nz 32) rdeepseq) -- -}+			{-let+				iteree = zip3D3 (lag3 points) (lag3s22 midsZ) (lag3s02 midsX)+				transform (((x0,y0,z0),(x1,y1,z1)), (midA0,midA1), (midB0,midB1)) =+					map2  (inj2 y0) $ +						getSegs (x0,z0) (x1,z1) (obj *$* y0) (midA0, midA1, midB0, midB1)+				result = for3 iteree transform+			in+				result -}+			{-par3DList (nx-1) (ny) (nz-1) $ \x mx y my z mz ->+		       map2  (inj2 (y 0)) $ getSegs' +		           (x 0, z 0)+                   (x 1, z 1)+                   (obj *$* y 0)+		           (midsZ ! (mx, my, mz), midsZ ! (mx+1, my, mz),+		            midsX ! (mx, my, mz), midsX ! (mx, my, mz+1))+		-- -}++		segsX = +			[[[ +			map2  (inj1 x0) $ getSegs (y0,z0) (y1,z1) (obj $** x0) +			     (objX0Y0Z0,objX0Y1Z0,objX0Y0Z1,objX0Y1Z1)+			     (midA0, midA1, midB0, midB1)+			 |x0<-pXs|             midB0<-mB'' |midB1<-mBT'      |midA0<-mA'' |midA1<-mA'T+			 |objX0Y0Z0<-objY0Z0|objX0Y1Z0<-    objY1Z0|objX0Y0Z1<-objY0Z1|objX0Y1Z1<-     objY1Z1+			]|y0<-pYs|y1<-tail pYs|mB'' <-mB'  |mBT' <-mBT       |mA'' <-mA'  |mA'T <-tail mA'+			 |objY0Z0  <-objZ0  |objY1Z0  <-tail objZ0  |objY0Z1  <-objZ1  |objY1Z1  <-tail objZ1  +			]|z0<-pZs|z1<-tail pZs|mB'  <-midsY|mBT  <-tail midsY|mA'  <-midsZ +			 |objZ0 <- objV | objZ1 <- tail objV+			]  `using` (parListChunk (max 1 $ div nz 32) rdeepseq) -- -}+			{-let+				iteree = zip3D3 (lag3 points) (lag3s12 midsZ) (lag3s02 midsY)+				transform (((x0,y0,z0),(x1,y1,z1)), (midA0,midA1), (midB0,midB1)) =+					map2  (inj1 x0) $ +						getSegs (y0,z0) (y1,z1) (obj $** x0) (midA0, midA1, midB0, midB1)+				result = for3 iteree transform+			in+				result -}++			{-par3DList (nx) (ny-1) (nz-1) $ \x mx y my z mz ->+		       map2  (inj1 (x 0)) $ getSegs'+		           (y 0, z 0)+                   (y 1, z 1)+                   (obj $** x 0)+		           (midsZ ! (mx, my, mz), midsZ ! (mx, my+1, mz),+		            midsY ! (mx, my, mz), midsY ! (mx, my, mz+1) ) -- -}++		-- (3) & (4) : get and tesselate loops+ +		sqTris = [[[+		    concat $ map (tesselateLoop res obj) $ getLoops $ concat [+		                segX''',+		           mapR segX''T,+		           mapR segY''',+		                segY'T',+		                segZ''',+		           mapR segZT''+		        ]++			 | segZ'''<- segZ''| segZT''<- segZT'+			 | segY'''<- segY''| segY'T'<- segY'T+			 | segX'''<- segX''| segX''T<- tail segX''++			]| segZ'' <- segZ' | segZT' <- segZT+			 | segY'' <- segY' | segY'T <- tail segY'+			 | segX'' <- segX'++			]| segZ'  <- segsZ | segZT  <- tail segsZ+			 | segY' <- segsY+			 | segX' <- segsX+		       ] `using` (parListChunk (nx*ny*(max 1 $ div nz 32)) rdeepseq)+	+	in mergedSquareTris $ concat $ concat $ concat sqTris -- (5) merge squares, etc++++-- silly utility functions++inj1 a (b,c) = (a,b,c)+inj2 b (a,c) = (a,b,c)+inj3 c (a,b) = (a,b,c)++infixr 0 $**+infixr 0 *$*+infixr 0 **$+f $** a = \(b,c) -> f (a,b,c)+f *$* b = \(a,c) -> f (a,b,c)+f **$ c = \(a,b) -> f (a,b,c)++appAB f a b = \c -> f (a,b,c)+appBC f b c = \a -> f (a,b,c)+appAC f a c = \b -> f (a,b,c)++map2 f = map (map f)+map2R f = map (reverse . map f)+mapR = map reverse++{-+lagzip a = zip a (tail a)+tupzip (a,b) = zip a b+tupzip3 (a,b,c) = zip3 a b c++zipD2 a b = map tupzip $ zip a b+zipD3 a b = map (map tupzip) . map tupzip $ zip a b++zip3D3 a b c = map (map tupzip3) . map tupzip3 $ zip3 a b c++lag3s02 = map (map tupzip) . map tupzip . lagzip+lag3s12 = map (map tupzip) . map lagzip+lag3s22 = map (map lagzip)++lag3 :: [[[a]]] -> [[[(a,a)]]]+lag3 a = zipD3 a $ map (map tail) $ map tail $ tail a++for3 = flip (map . map . map)+-}
+ Graphics/Implicit/Export/Render/Definitions.hs view
@@ -0,0 +1,14 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++module Graphics.Implicit.Export.Render.Definitions where++import Graphics.Implicit.Definitions+import Control.DeepSeq++data TriSquare = Sq (ℝ3,ℝ3,ℝ3) ℝ ℝ2 ℝ2 | Tris [Triangle]++instance NFData TriSquare where+	rnf (Sq b z xS yS) = rnf (b,z,xS,yS)+	rnf (Tris tris) = rnf tris+
+ Graphics/Implicit/Export/Render/GetLoops.hs view
@@ -0,0 +1,31 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++module Graphics.Implicit.Export.Render.GetLoops (getLoops) where++getLoops :: Eq a => [[a]] -> [[[a]]]+getLoops a = getLoops' a []++getLoops' :: Eq a => [[a]] -> [[a]] -> [[[a]]]++getLoops' [] [] = []++getLoops' (x:xs) [] = getLoops' xs [x]++getLoops' segs workingLoop | head (head workingLoop) == last (last workingLoop) =+	workingLoop : getLoops' segs []++getLoops' segs workingLoop =+	let+		presEnd = last $ last workingLoop+		connects (x:xs) = x == presEnd+		possibleConts = filter connects segs+		nonConts = filter (not . connects) segs+		(next, unused) = if null possibleConts+			then error "unclosed loop in paths given"+			else (head possibleConts, tail possibleConts ++ nonConts)+	in+		if null next+		then workingLoop : getLoops' segs []+		else getLoops' unused (workingLoop ++ [next])+
+ Graphics/Implicit/Export/Render/GetSegs.hs view
@@ -0,0 +1,79 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++module Graphics.Implicit.Export.Render.GetSegs where++import Graphics.Implicit.Definitions+import Graphics.Implicit.Export.Render.RefineSegs (refine)++getSegs' (x1, y1) (x2, y2) obj (midx1V,midx2V,midy1V,midy2V) = +	let+		x1y1 = obj (x1, y1)+		x2y1 = obj (x2, y1)+		x1y2 = obj (x1, y2)+		x2y2 = obj (x2, y2)+	in+		getSegs (x1, y1) (x2, y2) obj (x1y1, x2y1, x1y2, x2y2) (midx1V,midx2V,midy1V,midy2V)++getSegs :: ℝ2 -> ℝ2 -> Obj2 -> (ℝ,ℝ,ℝ,ℝ) -> (ℝ,ℝ,ℝ,ℝ) -> [Polyline]+{-- INLINE getSegs #-}+getSegs (x1, y1) (x2, y2) obj (x1y1, x2y1, x1y2, x2y2) (midx1V,midx2V,midy1V,midy2V) = +	let +		(x,y) = (x1, y1)++		-- Let's evlauate obj at a few points...+		c = obj ((x1+x2)/2, (y1+y2)/2)++		dx = x2 - x1+		dy = y2 - y1+		res = sqrt (dx*dy)++		midx1 = (x,      midx1V )+		midx2 = (x + dx, midx2V )+		midy1 = (midy1V , y )+		midy2 = (midy2V, y + dy)++		notPointLine (p1:p2:[]) = p1 /= p2++	in map (refine res obj) . 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)  -> [[midx2, midx1]]+		(False, True, +		 False, True)  -> [[midy2, midy1]]+		(True,  False,+		 True,  False) -> [[midy1, midy2]]+		(True,  False,+		 False, False) -> [[midx1, midy2]]+		(False, True, +		 True,  True)  -> [[midy2, midx1]]+		(True,  True, +		 False, True)  -> [[midx1, midy1]]+		(False, False,+		 True,  False) -> [[midy1, midx1]]+		(True,  True, +		 True,  False) -> [[midy1, midx2]]+		(False, False,+		 False, True)  -> [[midx2, midy1]]+		(True,  False,+		 True,  True)  -> [[midx2, midy2]]+		(False, True, +		 False, False) -> [[midy2, midx2]]+		(True,  False,+		 False, True)  -> if c <= 0+			then [[midx1, midy1], [midx2, midy2]]+			else [[midx1, midy2], [midx2, midy1]]+		(False, True, +		 True,  False) -> if c <= 0+			then [[midy2, midx1], [midy1, midx2]]+			else [[midy1, midx1], [midy2, midx2]]+
+ Graphics/Implicit/Export/Render/HandleSquares.hs view
@@ -0,0 +1,68 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++module Graphics.Implicit.Export.Render.HandleSquares (mergedSquareTris) where++import Graphics.Implicit.Definitions+import Graphics.Implicit.Export.Render.Definitions+import qualified Graphics.Implicit.SaneOperators as S+import GHC.Exts (groupWith)++mergedSquareTris sqTris = +	let+		triTriangles = concat $ map (\(Tris a) -> a) $ filter isTris sqTris	+		squares = filter (not . isTris) sqTris+		planeAligned = groupWith (\(Sq basis z _ _) -> (basis,z)) squares+		joined = map +			( concat . (map joinYaligned) . groupWith (\(Sq _ _ _ yS) -> yS)+			. concat . (map joinXaligned) . groupWith (\(Sq _ _ xS _) -> xS)) +			planeAligned+		finishedSquares = concat joined+	in+		triTriangles ++ concat (map squareToTri finishedSquares)+++isTris (Tris _) = True+isTris _ = False++joinXaligned (pres@(Sq b z xS (y1,y2)):sqs) = +	let+		isNext (Sq _ _ _ (a,_)) = a == y2+		isPrev (Sq _ _ _ (_,a)) = a == y1+	in case filter isNext sqs of+		[Sq _ _ _ (_, y3)] -> +			joinXaligned ((Sq b z xS (y1,y3)):(filter (not.isNext) sqs))+		_ -> case filter isPrev sqs of+			[Sq _ _ _ (y0, _)] -> +				joinXaligned ((Sq b z xS (y0,y2)):(filter (not.isPrev) sqs))+			_ -> pres : joinXaligned sqs+joinXaligned [] = []+++joinYaligned (pres@(Sq b z (x1,x2) yS):sqs) = +	let+		isNext (Sq _ _ (a,_) _) = a == x2+		isPrev (Sq _ _ (_,a) _) = a == x1+	in case filter isNext sqs of+		[Sq _ _ (_, x3) _] -> +			joinYaligned ((Sq b z (x1,x3) yS):(filter (not.isNext) sqs))+		_ -> case filter isPrev sqs of+			[Sq _ _ (x0, _) _] -> +				joinYaligned ((Sq b z (x0,x2) yS):(filter (not.isPrev) sqs))+			_ -> pres : joinYaligned sqs+joinYaligned [] = []+++squareToTri (Sq (b1,b2,b3) z (x1,x2) (y1,y2)) =+	let+		zV = b3 S.* z+		(x1V, x2V) = (x1 S.* b1, x2 S.* b1)+		(y1V, y2V) = (y1 S.* b2, y2 S.* b2)+		a = zV S.+ x1V S.+ y1V+		b = zV S.+ x2V S.+ y1V+		c = zV S.+ x1V S.+ y2V+		d = zV S.+ x2V S.+ y2V+	in+		[(a,b,c),(c,b,d)]++
+ Graphics/Implicit/Export/Render/Interpolate.hs view
@@ -0,0 +1,53 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++module Graphics.Implicit.Export.Render.Interpolate (interpolate) where++interpolate (a,aval) (b,bval) _ _ | aval*bval > 0 = a+interpolate (a,aval) (b,bval) f res = +	let+		a' = (a*95+5*b)/100+		b' = (b*95+5*a)/100+		a'val = f a'+		b'val = f b'+		deriva = abs $ 20*(aval - a'val)+		derivb = abs $ 20*(bval - b'val)+	in if deriva < 0.1 || derivb < 0.1+	then interpolate_bin 0 +		(if aval*a'val > 0 then (a',a'val) else (a,aval))+		(if bval*b'val > 0 then (b',b'val) else (b,bval))+		f+	else  interpolate_lin 0 +		(if aval*a'val > 0 then (a',a'val) else (a,aval))+		(if bval*b'val > 0 then (b',b'val) else (b,bval))+		f res++interpolate_lin _ (a, 0) _ _ _ = a+interpolate_lin _ _ (b, 0) _ _ = b+interpolate_lin n (a, aval) (b, bval) obj res | aval /= bval= +	let+		mid = a + (b-a)*aval/(aval-bval)+		midval = obj mid+	in if abs midval < res/500 || mid > 3+	then mid+	else if midval * aval > 0+	then interpolate_lin (n+1) (mid, midval) (b, bval) obj res+	else interpolate_lin (n+1) (a,aval) (mid, midval) obj res+interpolate_lin _ (a, _) _ _ _ = a++interpolate_bin n (a,aval) (b,bval) f = if aval > bval+	then interpolate_bin' n (a,aval) (b,bval) f+	else interpolate_bin' n (b,bval) (a,aval) f++interpolate_bin' 4 (a,aval) (b,bval) f = +	if abs aval < abs bval+	then a+	else b+interpolate_bin' n (a,aval) (b,bval) f =+	let+		mid = (a+b)/2+		midval = f mid+	in if midval > 0+	then interpolate_bin' (n+1) (mid,midval) (b,bval) f+	else interpolate_bin' (n+1) (a,aval) (mid,midval) f+
+ Graphics/Implicit/Export/Render/RefineSegs.hs view
@@ -0,0 +1,75 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++module Graphics.Implicit.Export.Render.RefineSegs where++import Graphics.Implicit.Definitions+import qualified Graphics.Implicit.SaneOperators as S+import Graphics.Implicit.SaneOperators ((⋅), (⨯), norm, normalized)++refine :: ℝ -> Obj2 -> [ℝ2] -> [ℝ2]+refine res obj = simplify res . detail' res obj+++detail' res obj [p1@(x1,y1), p2@(x2,y2)] | (x2-x1)^2 + (y2-y1)^2 > res^2/200 = +		detail 0 res obj [p1,p2]+detail' _ _ a = a++detail :: Int -> ℝ -> (ℝ2 -> ℝ) -> [ℝ2] -> [ℝ2]+detail n res obj [p1@(x1,y1), p2@(x2,y2)] | n < 2 =+	let+		mid@(midX, midY) = (p1 S.+ p2) S./ (2 :: ℝ)+		midval = obj mid +	in if abs midval < res / 40+	then [(x1,y1), (x2,y2)]+	else let+		normal = (\(a,b) -> (b, -a)) $ normalized (p2 S.- p1) +		derivN = -(obj (mid S.- (normal S.* (midval/2))) - midval) S.* (2/midval)+	in if abs derivN > 0.5 && abs derivN < 2+	then let+		mid' = mid S.- (normal S.* (midval / derivN))+	in detail (n+1) res obj [(x1,y1), mid'] +	   ++ tail (detail (n+1) res obj [mid', (x2,y2)] )+	else let+		derivX = (obj (midX + res/100, midY) - midval)*100/res+		derivY = (obj (midX, midY + res/100) - midval)*100/res+		derivNormSq = derivX^2+derivY^2+	in if abs derivNormSq > 0.09 && abs derivNormSq < 4+	then let+		(dX, dY) = (- derivX*midval/derivNormSq, - derivY*midval/derivNormSq)+		mid'@(midX', midY') = +			(midX + dX, midY + dY)+		midval' = obj mid'+		posRatio = midval/(midval - midval')+		mid''@(midX'', midY'') = (midX + dX*posRatio, midY + dY*posRatio)+	in +		detail (n+1) res obj [(x1,y1), mid''] ++ tail (detail (n+1) res obj [mid'', (x2,y2)] )+	else [(x1,y1), (x2,y2)]+++detail _ _ _ x = x++simplify res = {-simplify3 . simplify2 res . -} simplify1++simplify1 :: [ℝ2] -> [ℝ2]+simplify1 (a:b:c:xs) =+	if abs ( ((b S.- a) ⋅ (c S.- a)) - norm (b S.- a) * norm (c S.- a) ) < 0.0001+	then simplify1 (a:c:xs)+	else a : simplify1 (b:c:xs)+simplify1 a = a++{-+simplify2 :: ℝ -> [ℝ2] -> [ℝ2]+simplify2 res [a,b,c,d] = +	if norm (b S.- c) < res/10+	then [a, ((b S.+ c) S./ (2::ℝ)), d]+	else [a,b,c,d]+simplify2 _ a = a++simplify3 (a:as) | length as > 5 = simplify3 $ a : half (init as) ++ [last as]+	where+		half (a:b:xs) = a : half xs+		half a = a+simplify3 a = a++-}
+ Graphics/Implicit/Export/Render/TesselateLoops.hs view
@@ -0,0 +1,77 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++module Graphics.Implicit.Export.Render.TesselateLoops (tesselateLoop) where++import Graphics.Implicit.Definitions+import Graphics.Implicit.Export.Render.Definitions+import qualified Graphics.Implicit.SaneOperators as S+import Graphics.Implicit.SaneOperators ((⋅),norm,(⨯),normalized)+import Debug.Trace++tesselateLoop :: ℝ -> Obj3 -> [[ℝ3]] -> [TriSquare]++tesselateLoop _ _ [] = []++tesselateLoop _ _ [[a,b],[_,c],[_,_]] = return $ Tris [(a,b,c)]++tesselateLoop res obj [[_,_], as@(_:_:_:_),[_,_], bs@(_:_:_:_)] | length as == length bs =+	concat $ map (tesselateLoop res obj) $ +		[[[a1,b1],[b1,b2],[b2,a2],[a2,a1]] | ((a1,b1),(a2,b2)) <- zip (init pairs) (tail pairs)]+			where pairs = zip (reverse as) bs++tesselateLoop res obj [as@(_:_:_:_),[_,_], bs@(_:_:_:_), [_,_] ] | length as == length bs =+	concat $ map (tesselateLoop res obj) $ +		[[[a1,b1],[b1,b2],[b2,a2],[a2,a1]] | ((a1,b1),(a2,b2)) <- zip (init pairs) (tail pairs)]+			where pairs = zip (reverse as) bs++tesselateLoop res obj [[a,_],[b,_],[c,_],[d,_]] | (a S.+ c) == (b S.+ d) =+	let+		b1 = normalized $ a S.- b+		b2 = normalized $ c S.- b+		b3 = b1 ⨯ b2+	in [Sq (b1,b2,b3) (a ⋅ b3) (a ⋅ b1, c ⋅ b1) (a ⋅ b2, c ⋅ b2) ]++tesselateLoop res obj [[a,_],[b,_],[c,_],[d,_]] | obj ((a S.+ c) S./ (2 :: ℝ)) < res/30 =+	return $ Tris $ [(a,b,c),(a,c,d)]++tesselateLoop res obj pathSides = return $ Tris $+	let+		path' = concat $ map init pathSides+		(early_tris,path) = shrinkLoop 0 path' res obj+	in if null path+	then early_tris+	else let+		len = fromIntegral $ length path :: ℝ+		mid@(midx,midy,midz) = (foldl1 (S.+) path) S./ len+		midval = obj mid+		preNormal = foldl1 (S.+) $+			[ a ⨯ b | (a,b) <- zip path (tail path ++ [head path]) ]+		preNormalNorm = norm preNormal+		normal = preNormal S./ preNormalNorm+		deriv = (obj (mid S.+ (normal S.* (res/100)) ) - midval)/res*100+		mid' = mid S.- normal S.* (midval/deriv)+	in if abs midval > res/50 && preNormalNorm > 0.5 && abs deriv > 0.5 +		      && abs (deriv*midval) < 1.1*res && 5*abs (obj mid') < abs midval+		then early_tris ++ [(a,b,mid') | (a,b) <- zip path (tail path ++ [head path]) ]+		else early_tris ++ [(a,b,mid) | (a,b) <- zip path (tail path ++ [head path]) ]+++shrinkLoop :: Int -> [ℝ3] -> ℝ -> Obj3 -> ([Triangle], [ℝ3])++shrinkLoop _ path@[a,b,c] res obj =+	if   abs (obj ((a S.+ b S.+ c) S./ (3::ℝ) )) < res/50+	then +		( [(a,b,c)], [])+	else +		([], path)++shrinkLoop n path@(a:b:c:xs) res obj | n < length path =+	if abs (obj ((a S.+ c) S./ (2::ℝ) )) < res/50+	then +		let (tris,remainder) = shrinkLoop 0 (a:c:xs) res obj+		in ((a,b,c):tris, remainder)+	else +		shrinkLoop (n+1) (b:c:xs ++ [a]) res obj++shrinkLoop _ path _ _ = ([],path)
− Graphics/Implicit/Export/Symbolic/CoerceSymbolic2.hs 
@@ -1,28 +0,0 @@--- 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 
@@ -1,33 +0,0 @@--- 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/SymbolicFormats.hs view
@@ -0,0 +1,81 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++module Graphics.Implicit.Export.SymbolicFormats where++import Graphics.Implicit.Definitions+import Data.List as List++scad3 :: ℝ -> SymbolicObj3 -> String++scad3 res (UnionR3 0 objs) = +	"union() {\n"+	++ concat (map ((++"\n") . scad3 res) objs)+	++ "}\n"+scad3 res (DifferenceR3 0 objs) = +	"difference() {\n"+	++ concat (map ((++"\n") . scad3 res) objs)+	++ "}\n"+scad3 res (IntersectR3 0 objs) = +	"intersection() {\n"+	++ concat (map ((++"\n") . scad3 res) objs)+	++ "}\n"+scad3 res (Translate3 (x,y,z) obj) =+	"translate ([" ++ show x ++ "," ++ show y ++ "," ++ show z ++ "]) "+	++ scad3 res obj+scad3 res (Scale3 (x,y,z) obj) =+	"scale ([" ++ show x ++ "," ++ show y ++ "," ++ show z ++ "]) "+	++ scad3 res obj+scad3 _ (Rect3R 0 (x1,y1,z1) (x2,y2,z2)) =+	"translate ([" ++ show x1 ++ "," ++ show y1 ++ "," ++ show z1 ++ "]) "+	++ "cube ([" ++ show (x2-x1) ++ "," ++ show (y2-y1) ++ "," ++ show (z2-z1) ++ "]);"+scad3 _ (Cylinder h r1 r2) =+	"cylinder(r1 = " ++ show r1 ++ ", r2 = " ++ show r2 ++ ", " ++ show h ++ ");"+scad3 _ (Sphere r) =+	"sphere(r = " ++ show r ++");"+scad3 res (ExtrudeR 0 obj h) =+	"linear_extrude(" ++ show h ++ ")"+	++ scad2 res obj+scad3 res (ExtrudeRotateR 0 twist obj h) = +	"linear_extrude(" ++ show h ++ ", twist = " ++ show twist ++ " )"+	++ scad2 res obj+scad3 res (ExtrudeRM 0 (Just twist) Nothing Nothing obj (Left height)) =+	let+		for a b = map b a+		a ++! b = a ++ show b+	in (\pieces -> "union(){" ++ concat pieces ++ "}") . for (init [0, res.. height]) $ \h ->+		"rotate ([0,0," ++! twist h ++ "]) "+		++ "linear_extrude(" ++! res ++ ", twist = " ++! (twist (h+res) - twist h) ++ " )"+		++ scad2 res obj++scad2 res (UnionR2 0 objs) = +	"union() {\n"+	++ concat (map ((++"\n") . scad2 res) objs)+	++ "}\n"+scad2 res (DifferenceR2 0 objs) = +	"difference() {\n"+	++ concat (map ((++"\n") . scad2 res) objs)+	++ "}\n"+scad2 res (IntersectR2 0 objs) = +	"intersection() {\n"+	++ concat (map ((++"\n") . scad2 res) objs)+	++ "}\n"+scad2 res (Translate2 (x,y) obj) =+	"translate ([" ++ show x ++ "," ++ show y ++ "," ++ "]) "+	++ scad2 res obj+scad2 res (Scale2 (x,y) obj) =+	"scale ([" ++ show x ++ "," ++ show y ++ "]) "+	++ scad2 res obj+scad2 _ (RectR 0 (x1,y1) (x2,y2)) =+	"translate ([" ++ show x1 ++ "," ++ show y1 ++ "]) "+	++ "cube ([" ++ show (x2-x1) ++ "," ++ show (y2-y1) ++ "]);"+scad2 _ (Circle r) = "circle(" ++ show r ++ ");"+scad2 _ (PolygonR 0 points) = +	"polygon(" +	++ "[" +	++ (concat. List.intersperse "," . map (\(a,b) -> "["++show a++","++show b++"]" ) $ points)+	++ "]"+	++ ");"+++
Graphics/Implicit/Export/SymbolicObj2.hs view
@@ -14,34 +14,45 @@ 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.ObjectUtil -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 +symbolicGetOrientedContour :: ℝ ->  SymbolicObj2 -> [Polyline]+symbolicGetOrientedContour res symbObj = map orient $ symbolicGetContour res symbObj+	where+		obj = getImplicit2 symbObj+		orient :: Polyline -> Polyline+		orient points@(x:y:_) = +			let +				v = (\(a,b) -> (b, -a)) (y S.- x)+				dv = v S./ (S.norm v / res / 0.1)+			in if obj (x S.+ dv) - obj x > 0+			then points+			else reverse points  symbolicGetContour :: ℝ ->  SymbolicObj2 -> [Polyline] symbolicGetContour _ (RectR 0 (x1,y1) (x2,y2)) = [[ (x1,y1), (x2,y1), (x2,y2), (x1,y2), (x1,y1) ]] symbolicGetContour res (Circle r) = [[ ( r*cos(2*pi*m/n), r*sin(2*pi*m/n) ) | m <- [0.. n] ]] where 	n = max 5 (fromIntegral $ ceiling $ 2*pi*r/res) 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+symbolicGetContour res (Scale2 s obj) = map (map (S.⋯* s)) $ symbolicGetContour res obj+symbolicGetContour res obj = case rebound2 (getImplicit2 obj, getBox2 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 (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) = @@ -51,7 +62,7 @@ 	  )| m <- [0.. n-1] ]  	where 		n = max 5 (fromIntegral $ ceiling $ 2*pi*r/res)-symbolicGetContourMesh res obj = case rebound2 (coerceSymbolic2 obj) of+symbolicGetContourMesh res obj = case rebound2 (getImplicit2 obj, getBox2 obj) of 	(obj, (a,b)) -> getContourMesh a b (res,res) obj
Graphics/Implicit/Export/SymbolicObj3.hs view
@@ -12,27 +12,33 @@ import Graphics.Implicit.Definitions  import Graphics.Implicit.Export.Definitions-import Graphics.Implicit.Export.MarchingCubes+import Graphics.Implicit.Export.Render (getMesh) -import Graphics.Implicit.Operations import Graphics.Implicit.Primitives+import Graphics.Implicit.ObjectUtil+import Graphics.Implicit.MathUtil  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 qualified Data.Maybe as Maybe+ import Graphics.Implicit.Export.Symbolic.Rebound2 import Graphics.Implicit.Export.Symbolic.Rebound3-import Graphics.Implicit.Export.Util (divideMeshTo, dividePolylineTo)+--import Graphics.Implicit.Export.Util (divideMeshTo, dividePolylineTo)+import Graphics.Implicit.Export.Util (normTriangle)   instance DiscreteAproxable SymbolicObj3 TriangleMesh where 	discreteAprox res obj = symbolicGetMesh res obj +instance DiscreteAproxable SymbolicObj3 NormedTriangleMesh where+	discreteAprox res obj = map (normTriangle res (getImplicit3 obj)) $ symbolicGetMesh res obj+ symbolicGetMesh :: ℝ -> SymbolicObj3 -> [(ℝ3, ℝ3, ℝ3)] +{-- -- A translated objects mesh is its mesh translated. symbolicGetMesh res (Translate3 v obj) =  	map (\(a,b,c) -> (a S.+ v, b S.+ v, c S.+ v) ) (symbolicGetMesh res obj)@@ -43,34 +49,48 @@ 		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)+		scaleTriangle (a,b,c) = (s S.⋯* a, s S.⋯* b, s S.⋯* c) 	in map scaleTriangle  mesh  -- A couple triangles make a cube... symbolicGetMesh _ (Rect3R 0 (x1,y1,z1) (x2,y2,z2)) =  	let 		square a b c d = [(a,b,c),(d,a,c)]+		rsquare a b c d = [(c,b,a),(c,a,d)] 	in-		   square (x1,y1,z1) (x2,y1,z1) (x2,y2,z1) (x1,y2,z1)+		   rsquare (x1,y1,z1) (x2,y1,z1) (x2,y2,z1) (x1,y2,z1) 		++ square (x1,y1,z2) (x2,y1,z2) (x2,y2,z2) (x1,y2,z2) 		++ square (x1,y1,z1) (x2,y1,z1) (x2,y1,z2) (x1,y1,z2)-		++ square (x1,y2,z1) (x2,y2,z1) (x2,y2,z2) (x1,y2,z2)+		++ rsquare (x1,y2,z1) (x2,y2,z1) (x2,y2,z2) (x1,y2,z2) 		++ square (x1,y1,z1) (x1,y1,z2) (x1,y2,z2) (x1,y2,z1)-		++ square (x2,y1,z1) (x2,y1,z2) (x2,y2,z2) (x2,y2,z1)+		++ rsquare (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+-- Use spherical coordinates to create an easy tesselation of a sphere+symbolicGetMesh res (Sphere r) = half1 ++ half2+	where+		-- Convenience functions for mesh generation 		square a b c d = [(a,b,c),(d,a,c)]-		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] ]+		rsquare a b c d = [(c,b,a),(c,a,d)]+		-- Number of steps of φ and θ respectivly+		m = max 3 (fromIntegral $ ceiling $ 1.5*r/res)+		n = 2*m+		-- Spherical coordinates+		spherical θ φ = (r*cos(θ), r*sin(θ)*cos(φ), r*sin(θ)*sin(φ))+		-- Function placing steps on sphere+		f n' m' = spherical (2*pi*n'/n) (pi*m'/m)+		-- Mesh in two pieces..+		half1 = concat [ square (f m1 m2) (f (m1+1) m2) (f (m1+1) (m2+1)) (f m1 (m2+1)) +		                | m1 <- [0.. m-1], m2 <- [0.. m-1] ]+		half2 = concat [ rsquare (f m1 m2) (f (m1+1) m2) (f (m1+1) (m2+1)) (f m1 (m2+1)) +		                | m1 <- [m.. n-1], m2 <- [0.. m-1] ] +{-symbolicGetMesh res (UnionR3 r [ExtrudeR ra obja ha, ExtrudeR rb objb hb]) +	| ha == hb && ra == rb = symbolicGetMesh res $ ExtrudeR ra (UnionR2 r [obja, objb]) ha++symbolicGetMesh res (UnionR3 r [ExtrudeR ra obja ha, ExtrudeR rb objb hb, ExtrudeR rc objc hc]) +	| ha == hb && ha == hc && ra == rb && ra == rc = +		symbolicGetMesh res $ ExtrudeR ra (UnionR2 r [obja, objb, objc]) ha-}+ -- We can compute a mesh of a rounded, extruded object from it contour,  -- contour filling trinagles, and magic. -- General approach:@@ -81,7 +101,7 @@ 	let 		-- Get a Obj2 (magnitude descriptor object) 		obj2mag :: ℝ2 -> ℝ -- Obj2-		obj2mag = fst $ coerceSymbolic2 obj2+		obj2mag = getImplicit2 obj2 		-- The amount that a point (x,y) on the top should be lifted 		-- from h-r. Because of rounding, the edges should be h-r, 		-- but it should increase inwards.@@ -89,6 +109,8 @@ 		-- Turn a polyline into a list of its segments 		segify (a:b:xs) = (a,b):(segify $ b:xs) 		segify _ = []+		-- Flip a triangle. It's the same triangle with opposite handedness.+		flipTri (a,b,c) = (a,c,b) 		-- Turn a segment a--b into a list of triangles forming (a--b)×(r,h-r) 		-- The dh stuff is to compensate for rounding errors, etc, and ensure that 		-- the sides meet the top and bottom@@ -96,14 +118,14 @@ 			[((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+		segs = concat $ map segify $ symbolicGetOrientedContour res obj2 		-- Create sides for the main body of our object = segs × (r,h-r) 		side_tris = concat $ map (\(a,b) -> segToSide a b) segs 		-- Triangles that fill the contour. Make sure the mesh is at least (res/5) fine. 		-- --res/5 because xyres won't always match up with normal res and we need to compensate. 		fill_tris = {-divideMeshTo (res/5) $-} symbolicGetContourMesh res obj2 		-- The bottom. Use dh to determine the z coordinates-		bottom_tris = [((a1,a2,r-dh a1 a2), (b1,b2,r - dh b1 b2), (c1,c2,r - dh c1 c2)) +		bottom_tris = map flipTri $ [((a1,a2,r-dh a1 a2), (b1,b2,r - dh b1 b2), (c1,c2,r - dh c1 c2))  				| ((a1,a2),(b1,b2),(c1,c2)) <- fill_tris] 		-- Same idea at the top. 		top_tris = [((a1,a2,h-r+dh a1 a2), (b1,b2,h-r+dh b1 b2), (c1,c2,h-r+dh c1 c2)) @@ -113,14 +135,18 @@ 		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) = +symbolicGetMesh res  (ExtrudeRM r twist scale translate obj2 h) =  	let 		-- Get a Obj2 (magnitude descriptor object) 		obj2mag :: Obj2 -- = ℝ2 -> ℝ-		obj2mag = fst $ coerceSymbolic2 obj2+		obj2mag = getImplicit2 obj2+		-- cleanup twist, scale, etc+		twist' = Maybe.fromMaybe (const 0) twist+		scale' = Maybe.fromMaybe (const 1) scale+		translate' = Maybe.fromMaybe (const (0,0)) translate+		h' = case h of+			Left n -> const n+			Right f -> f 		-- The amount that a point (x,y) on the top should be lifted 		-- from h-r. Because of rounding, the edges should be h-r, 		-- but it should increase inwards.@@ -128,8 +154,10 @@ 		-- Turn a polyline into a list of its segments 		segify (a:b:xs) = (a,b):(segify $ b:xs) 		segify _ = []+		-- Flip a triangle. It's the same triangle with opposite handedness.+		flipTri (a,b,c) = (a,c,b) 		-- The number of steps we're going to do the sides in:-		n = fromIntegral $ ceiling $ h/res+		n = max 4 $ fromIntegral $ ceiling $ h' (0,0)/res 		-- Turn a segment a--b into a list of triangles forming  		--    (a--b)×(r+(h-2r)*m/n,r+(h-2r)*(m+1)/n) 		-- The dh stuff is to compensate for rounding errors, etc, and ensure that@@ -139,22 +167,22 @@ 			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+				mainH1 = h' (x1, y1) - 2*r + 2*dh x1 y1+				mainH2 = h' (x2, y2) - 2*r + 2*dh x2 y2 				-- level a (lower) and level b (upper) 				la1 = r-dh x1 y1  +  mainH1*m/n 				lb1 = r-dh x1 y1  +  mainH1*(m+1)/n-				la2 = r-dh x2 y2  +  mainH1*m/n-				lb2 = r-dh x2 y2  +  mainH1*(m+1)/n+				la2 = r-dh x2 y2  +  mainH2*m/n+				lb2 = r-dh x2 y2  +  mainH2*(m+1)/n 			in 				-- Resulting triangles:  				[((x1,y1,la1), (x2,y2,la2), (x2,y2,lb2)),  				 ((x1,y1,la1), (x2,y2,lb2), (x1,y1,lb1)) ] 		-- Get a contour polyline for obj2, turn it into a list of segments-		segs = concat $ map segify $ symbolicGetContour res obj2+		segs = concat $ map segify $ symbolicGetOrientedContour res obj2 		-- Create sides for the main body of our object = segs × (r,h-r) 		-- Many layers...-		side_tris = concat $+		side_tris = map flipTri $ concat $ 			[concat $ map (\(a,b) -> segToSide m a b) segs | m <- [0.. n-1] ] 		-- Triangles that fill the contour. Make sure the mesh is at least (res/5) fine. 		-- --res/5 because xyres won't always match up with normal res and we need to compensate.@@ -163,13 +191,16 @@ 		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)) +		top_tris = map flipTri $ [((a1,a2,h' (a1,a2) -r+dh a1 a2), (b1,b2,h' (b1,b2) -r+dh b1 b2), (c1,c2,h' (c1,c2)-r+dh c1 c2))  				| ((a1,a2),(b1,b2),(c1,c2)) <- fill_tris] 		-- Mesh modifiers in individual components+		k = 2*pi/360 		fx :: ℝ3 -> ℝ-		fx (x,y,z) = fst $ mod z (x,y)+		fx (x,y,z) = let (tx,ty) = translate' z in+			scale' z *((x+tx)*cos(k*twist' z) + (y+ty)*sin(k*twist' z)) 		fy :: ℝ3 -> ℝ-		fy (x,y,z) = snd $ mod z (x,y)+		fy (x,y,z) =let (tx,ty) = translate' z in+			scale' z *((x+tx)*sin(k*twist' z) - (y+ty)*cos(k*twist' z)) 		-- function to transform a triangle 		transformTriangle :: (ℝ3,ℝ3,ℝ3) -> (ℝ3,ℝ3,ℝ3) 		transformTriangle (a@(_,_,z1), b@(_,_,z2), c@(_,_,z3)) = @@ -177,12 +208,34 @@  	in 		map transformTriangle (side_tris ++ bottom_tris ++ top_tris)+-} +symbolicGetMesh res inputObj@(UnionR3 r objs) = +	let+		boxes = map getBox3 objs+		boxedObjs = zip boxes objs+		+		sepFree ((box,obj):others) = +			if length (filter (box3sWithin r box) boxes) > 1+			then (\(a,b) -> (obj:a,b)) $ sepFree others+			else (\(a,b) -> (a,obj:b)) $ sepFree others+		sepFree [] = ([],[])++		(dependants, independents) = sepFree boxedObjs+	in if null independents+	then case rebound3 (getImplicit3 inputObj, getBox3 inputObj) of+		(obj, (a,b)) -> getMesh a b res obj +	else if null dependants+	then concat $ map (symbolicGetMesh res) independents+	else concat $ +		map (symbolicGetMesh res) independents +		++ [symbolicGetMesh res (UnionR3 r dependants)]+ -- If all that fails, coerce and apply marching cubes :( -- (rebound is for being safe about the bounding box -- --  it slightly streches it to make sure nothing will  --  have problems because it is right at the edge ) symbolicGetMesh res  obj = -	case rebound3 (coerceSymbolic3 obj) of+	case rebound3 (getImplicit3 obj, getBox3 obj) of 		(obj, (a,b)) -> getMesh a b res obj
Graphics/Implicit/Export/TriangleMeshFormats.hs view
@@ -24,3 +24,42 @@ 			++ (concat $ map stlTriangle triangles) 			++ stlFooter ++jsTHREE :: TriangleMesh -> String+jsTHREE triangles = text+	where+		-- some dense JS. Let's make helper functions so that we don't repeat code each line+		header = +			"var Shape = function(){\n"+			++  "var s = this;\n"+			++  "THREE.Geometry.call(this);\n"+			++  "function vec(x,y,z){return new THREE.Vector3(x,y,z);}\n"+			++  "function v(x,y,z){s.vertices.push(vec(x,y,z));}\n"+			++  "function f(a,b,c){"+			++    "s.faces.push(new THREE.Face3(a,b,c));"+			++  "}\n"+		footer =+			"}\n"+			++ "Shape.prototype = new THREE.Geometry();\n"+			++ "Shape.prototype.constructor = Shape;\n"+		-- A vertex line; v (0.0, 0.0, 1.0) = "v(0.0,0.0,1.0);\n"+		v :: ℝ3 -> String+		v (x,y,z) = "v("  ++ show x ++ "," ++ show y ++ "," ++ show z ++ ");\n"+		-- A face line+		f :: Int -> Int -> Int -> String+		f posa posb posc = +			"f(" ++ show posa ++ "," ++ show posb ++ "," ++ show posc ++ ");"+		verts = do+			-- extract the vertices for each triangle+			-- recall that a normed triangle is of the form ((vert, norm), ...)+			(a,b,c) <- triangles+			-- The vertices from each triangle take up 3 position in the resulting list+			[a,b,c]+		vertcode = concat $ map v verts+		facecode = concat $ do+			(n,_) <- zip [0, 3 ..] triangles+			let+				(posa, posb, posc) = (n, n+1, n+2)+			return $ f posa posb posc+		text = header ++ vertcode ++ facecode ++ footer+
Graphics/Implicit/Export/Util.hs view
@@ -5,13 +5,40 @@  -- Functions to make meshes/polylines finer. -module Graphics.Implicit.Export.Util (divideMesh2To, divideMeshTo, dividePolylineTo) where+module Graphics.Implicit.Export.Util {-(divideMesh2To, divideMeshTo, dividePolylineTo)-} where --- import Prelude hiding ((+),(-),(*),(/))+import Prelude hiding ((+),(-),(*),(/)) import Graphics.Implicit.Definitions-import qualified Graphics.Implicit.SaneOperators as S+import Graphics.Implicit.SaneOperators --- If we need to make a 2D mesh finer...+normTriangle :: ℝ -> Obj3 -> Triangle -> NormedTriangle+normTriangle res obj tri@(a,b,c) = +	(normify a', normify b', normify c') +		where +			normify = normVertex res obj+			a' = (a + r*b + r*c)/(1.02 :: ℝ)+			b' = (b + r*a + r*c)/(1.02 :: ℝ)+			c' = (c + r*b + r*a)/(1.02 :: ℝ)+			r = 0.01 :: ℝ++normVertex :: ℝ -> Obj3 -> ℝ3 -> (ℝ3, ℝ3)+normVertex res obj p@(x,y,z) = +	let+		-- D_vf(p) = ( f(p) - f(p+v) ) /|v|+		-- but we'll actually scale v by res, so then |v| = res+		-- and that f is obj+		-- and is fixed at p+		-- so actually: d v = ...+		d :: ℝ3 -> ℝ+		d v = ( obj (p + (res/(100::ℝ))*v) - obj (p - (res/(100::ℝ))*v) ) /(res/(50::ℝ))+		dx = d (1, 0, 0)+		dy = d (0, 1, 0)+		dz = d (0, 0, 1)+		nonUnitNormal = (dx,dy,dz)+		normal = nonUnitNormal / norm nonUnitNormal+	in ((x,y,z), normal)++{--- If we need to make a 2D mesh finer... divideMesh2To :: ℝ -> [(ℝ2, ℝ2, ℝ2)] -> [(ℝ2, ℝ2, ℝ2)] divideMesh2To res mesh = 	let @@ -73,4 +100,4 @@ 			else [polyline !! n]  -+-}
Graphics/Implicit/ExtOpenScad.hs view
@@ -3,16 +3,18 @@  -- We'd like to parse openscad code, with some improvements, for backwards compatability. -module Graphics.Implicit.ExtOpenScad (runOpenscad) where+module Graphics.Implicit.ExtOpenScad (runOpenscad, OpenscadObj (..) ) where +import Graphics.Implicit.ExtOpenScad.Definitions (OpenscadObj (..) ) import Graphics.Implicit.ExtOpenScad.Default (defaultObjects)-import Graphics.Implicit.ExtOpenScad.Statements (computationStatement, runComputations)+import Graphics.Implicit.ExtOpenScad.Statements (computationStatement)+import Graphics.Implicit.ExtOpenScad.Util.Computation (runComputations) -import Text.ParserCombinators.Parsec (parse, many1)+import Text.ParserCombinators.Parsec (parse, many1, many, space, eof) import Control.Monad (liftM)  -- Small wrapper to handle parse errors, etc-runOpenscad str = case parse (many1 computationStatement) ""  str of+runOpenscad str = case parse (do {s <- many1 computationStatement; many space; eof; return s}) ""  str of 	Right res -> Right $ runComputationsDefault res 	Left  err ->  Left err
Graphics/Implicit/ExtOpenScad/Default.hs view
@@ -7,6 +7,7 @@  import Graphics.Implicit.Definitions import Graphics.Implicit.ExtOpenScad.Definitions+import Graphics.Implicit.ExtOpenScad.Primitives import Data.Map (Map, fromList)  defaultObjects :: VariableLookup -- = Map String OpenscadObj@@ -15,47 +16,52 @@ 	++ defaultFunctions 	++ defaultFunctions2 	++ defaultFunctionsSpecial+	++ defaultModules -defaultConstants = map (\(a,b) -> (a, ONum b))+-- Missing standard ones:+-- rand, lookup, ++defaultConstants = map (\(a,b) -> (a, toOObj (b::ℝ) )) 	[("pi", pi)] -defaultFunctions = map (\(a,b) -> (a, numericOFunc b))+defaultFunctions = map (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ))) 	[ 		("sin",   sin), 		("cos",   cos), 		("tan",   tan),+		("asin",  asin),+		("acos",  acos),+		("atan",  atan), 		("abs",   abs), 		("sign",  signum), 		("floor", fromIntegral . floor ), 		("ceil",  fromIntegral . ceiling ),-		("exp",   exp)+		("round", fromIntegral . round ),+		("exp",   exp),+		("ln",    log),+		("log",   log),+		("sign",  signum),+		("sqrt",  sqrt) 	] -defaultFunctions2 = map (\(a,b) -> (a, numericOFunc2 b))+defaultFunctions2 = map (\(a,b) -> (a, toOObj (b :: ℝ -> ℝ -> ℝ) )) 	[ 		("max", max),-		("min", min)+		("min", min),+		("atan2", atan2),+		("pow", (**)) 	] -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+defaultFunctionsSpecial = +	[+		("map", toOObj $ flip $ +			(map :: (OpenscadObj -> OpenscadObj) -> [OpenscadObj] -> [OpenscadObj] ) +		)+		+	]  -numericOFunc2 f = OFunc $ \oObj -> case oObj of-	ONum n -> OFunc $ \oObj2 -> case oObj2 of-		ONum n2 -> ONum $ f n n2-		_ -> OUndefined-	_ -> OUndefined+defaultModules =+	map (\(a,b) -> (a, OModule b)) primitives
Graphics/Implicit/ExtOpenScad/Definitions.hs view
@@ -3,10 +3,15 @@  -- We'd like to parse openscad code, with some improvements, for backwards compatability. +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ScopedTypeVariables, IncoherentInstances, ViewPatterns  #-}+ module Graphics.Implicit.ExtOpenScad.Definitions where  import Graphics.Implicit.Definitions+import Data.Typeable (TypeRep) import Data.Map (Map)+import Data.Maybe (isJust)+import Control.Monad as Monad  -- Lets make it easy to change the object types we're using :) @@ -15,16 +20,111 @@ -- | The 3D object type to be used in ExtOpenScad type Obj3Type = SymbolicObj3 +-- | To look up OpenscadObj variables with a string name type VariableLookup = Map String OpenscadObj +-- | Objects for our OpenSCAD-like language data OpenscadObj = OUndefined  		 | OBool Bool  		 | ONum ℝ 		 | OList [OpenscadObj] 		 | OString String 		 | OFunc ( OpenscadObj -> OpenscadObj ) -		 | OModule (ArgParser ComputationStateModifier)+		 | OModule ([ComputationStateModifier]  -> ArgParser ComputationStateModifier)+		 | OError [String] +instance Eq OpenscadObj where+	(ONum a) == (ONum b) = a == b+	(OBool a) == (OBool b) = a == b+	(OList a) == (OList b) = a == b+	(OString a) == (OString b) = a == b+	_ == _ = False++-- | We'd like to be able to turn OpenscadObjs into a given Haskell type+class OTypeMirror a where+	fromOObj :: OpenscadObj -> Maybe a+	toOObj :: a -> OpenscadObj++instance OTypeMirror OpenscadObj where+	fromOObj a = Just a+	toOObj a = a++instance OTypeMirror ℝ where+	fromOObj (ONum n) = Just n+	fromOObj _ = Nothing+	toOObj n = ONum n++instance OTypeMirror ℕ where+	fromOObj (ONum n) = if n == fromIntegral (floor n) then Just (floor n) else Nothing+	fromOObj _ = Nothing+	toOObj n = ONum $ fromIntegral n++instance OTypeMirror Bool where+	fromOObj (OBool b) = Just b+	fromOObj _ = Nothing+	toOObj b = OBool b++instance OTypeMirror String where+	fromOObj (OString str) = Just str+	fromOObj _ = Nothing+	toOObj str = OString str++instance forall a. (OTypeMirror a) => OTypeMirror (Maybe a) where+	fromOObj a = Just $ fromOObj a+	toOObj (Just a) = toOObj a+	toOObj Nothing  = OUndefined++instance forall a. (OTypeMirror a) => OTypeMirror [a] where+	fromOObj (OList list) = Monad.sequence . map fromOObj $ list+	fromOObj _ = Nothing+	toOObj list = OList $ map toOObj list++instance forall a b. (OTypeMirror a, OTypeMirror b) => OTypeMirror (a,b) where+	fromOObj (OList ((fromOObj -> Just a):(fromOObj -> Just b):[])) = Just (a,b)+	fromOObj _ = Nothing+	toOObj (a,b) = OList [toOObj a, toOObj b]+++instance forall a b c. (OTypeMirror a, OTypeMirror b, OTypeMirror c) => OTypeMirror (a,b,c) where+	fromOObj (OList ((fromOObj -> Just a):(fromOObj -> Just b):(fromOObj -> Just c):[])) = +		Just (a,b,c)+	fromOObj _ = Nothing+	toOObj (a,b,c) = OList [toOObj a, toOObj b, toOObj c]++instance forall a b. (OTypeMirror a, OTypeMirror b) => OTypeMirror (a -> b) where+	fromOObj (OFunc f) =  Just $ \input ->+		let+			oInput = toOObj input+			oOutput = f oInput+			output = fromOObj oOutput :: Maybe b+		in case output of+			Just out -> out+			Nothing -> error $ "coercing OpenscadObj to a -> b isn't always safe; use a -> Maybe b"+			              ++ " (trace: " ++ show oInput ++ " -> " ++ show oOutput ++ " )"+	fromOObj _ = Nothing+	toOObj f = OFunc $ \oObj -> +		case fromOObj oObj :: Maybe a of+			Nothing  -> OError ["bad input type"]+			Just obj -> toOObj $ f obj+++instance forall a b. (OTypeMirror a, OTypeMirror b) => OTypeMirror (Either a b) where+	fromOObj (fromOObj -> Just (x :: a)) = Just $ Left  x+	fromOObj (fromOObj -> Just (x :: b)) = Just $ Right x+	fromOObj _ = Nothing++	toOObj (Right x) = toOObj x+	toOObj (Left  x) = toOObj x++objTypeStr (OUndefined) = "Undefined"+objTypeStr (OBool   _ ) = "Bool"+objTypeStr (ONum    _ ) = "Number"+objTypeStr (OList   _ ) = "List"+objTypeStr (OString _ ) = "String"+objTypeStr (OFunc   _ ) = "Function"+objTypeStr (OModule _ ) = "Module"+objTypeStr (OError  _ ) = "Error"+ instance Show OpenscadObj where 	show OUndefined = "Undefined" 	show (OBool b) = show b@@ -32,10 +132,28 @@ 	show (OList l) = show l 	show (OString s) = show s 	show (OFunc f) = "<function>"+	show (OModule _) = "module"+	show (OError msgs) = "Execution Error:\n" ++ foldl1 (\a b -> a ++ "\n" ++ b) msgs -data ArgParser a = ArgParser String (Maybe OpenscadObj) (OpenscadObj -> ArgParser a) +-- | Handles parsing arguments to modules+data ArgParser a +                 -- | For actual argument entries:+                 --   ArgParser (argument name) (default) (doc) (next Argparser...)+                 = ArgParser String (Maybe OpenscadObj) String (OpenscadObj -> ArgParser a) +                 -- | For returns:+                 --   ArgParserTerminator (return value)                  | ArgParserTerminator a -                 | ArgParserFail+                 -- | For failure:+                 --   ArgParserFailIf (test) (error message) (child for if true)+                 | ArgParserFailIf Bool String (ArgParser a)+                 --  An example, then next+                 | ArgParserExample String (ArgParser a)+                 --  A string to run as a test, then invariants for the results, then next+                 | ArgParserTest String [TestInvariant] (ArgParser a)+	deriving (Show)++data TestInvariant = EulerCharacteristic Int +	deriving (Show)  type ComputationState = IO (VariableLookup, [Obj2Type], [Obj3Type])
Graphics/Implicit/ExtOpenScad/Expressions.hs view
@@ -13,6 +13,17 @@ import Text.ParserCombinators.Parsec  import Text.ParserCombinators.Parsec.Expr +errorAsAppropriate _   err@(OError _)   _ = err+errorAsAppropriate _   _   err@(OError _) = err+errorAsAppropriate name a b = OError +	["Can't " ++ name ++ " objects of types " ++ objTypeStr a ++ " and " ++ objTypeStr b ++ "."]++pad parser = do+	many space+	a <- parser+	many space+	return a+ variableSymb = many1 (noneOf " ,|[]{}()+-*&^%#@!~`'\"\\/;:.,<>?=") <?> "variable"  variable :: GenParser Char st (VariableLookup -> OpenscadObj)@@ -48,18 +59,18 @@  expression :: Int -> GenParser Char st (VariableLookup -> OpenscadObj) expression 10 = (try literal) <|> (try variable )-	<|> ((do+	<|> ((do -- ( 1 + 5 ) 		string "("; 		expr <- expression 0; 		string ")"; 		return expr; 	) <?> "bracketed expression" )-	<|> ( try ( do+	<|> ( try ( do -- [ 3, a, a+1, b, a*b ] 		string "["; 		exprs <- sepBy (expression 0) (char ',' ); 		string "]"; 		return $ \varlookup -> OList (map ($varlookup) exprs )-	) <|> ( do+	) <|> ( do -- eg.  [ a : 1 : a + 10 ] 		string "["; 		exprs <- sepBy (expression 0) (char ':' ); 		string "]";@@ -76,88 +87,135 @@ 		applyArgs :: OpenscadObj -> [OpenscadObj] -> OpenscadObj 		applyArgs obj []  = obj 		applyArgs (OFunc f) (arg:others) = applyArgs (f arg) others -		applyArgs _ _ = OUndefined+		applyArgs a b = errorAsAppropriate "apply" a (OList b) 		-- List splicing, like in Python. 'Cause list splicing is 		-- awesome!+		-- eg. a = [0:10]; a[2:4] = [2,3,4] 		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 ) )+			| 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 = []+		modifier = +			(try $ (do+				many space+				string "("+				args <- sepBy +					(expression 0) +					(many space >> char ',' >> many space)+				string ")"+				many space+				return $ \f varlookup -> applyArgs (f varlookup) (map ($varlookup) args) +			<?> "function application"+			)) <|> (try $ (do+				many space+				string "[";+				i <- pad $ expression 0;+				string "]";+				many space+				return $ \l 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+				string "[";+				many space+				start <- (try $ expression 0) <|> (many space >> return (\_ -> OUndefined));+				many space+				char ':';+				many space+				end   <- (try $ expression 0) <|> (many space >> return (\_ -> OUndefined));+				many space+				string "]";+				return $ \l 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"))+		 	in ( try( do -		f <- expression 10;+		obj <- 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" )+		mods <- modifier `sepBy` (many space)+		many space+		return $ \varlookup -> foldl (\a b -> b a) obj mods $ varlookup+		) <?> "list splicing" ) 	<|> try (expression 10) expression n@8 = try (( do  		a <- expression (n+1);+		many space 		string "^";+		many space 		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 = +expression n@7 =  	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+		mult a         b         = errorAsAppropriate "multiply" a b  		div (ONum a)  (ONum b) = ONum  (a/b) 		div (OList a) (ONum b) = OList (map (\x -> div x (ONum b)) a)-		div _         _        = OUndefined+		div a         b        = errorAsAppropriate "divide" a b 	in try (( do -		exprs <- sepBy1 (sepBy1 (expression $ n+1) (char '/')) (char '*')+		-- outer list is multiplication, inner division. objects are +		-- expressions and take a varlookup to evaluate.+		-- eg. "1*2*3/4/5*6*7/8"+		--     [[vl→1],[vl→2],[vl→3,vl→4,vl→5],[vl→6],[vl→7,vl→8]]+		exprs <- sepBy1 (sepBy1 (pad $ expression $ n+1) +			(many space >> char '/' >> many space )) +			(many space >> char '*' >> many space)+		--     [[1],[2],[3,4,5],[6],[7,8]]+		--     [ 1,  2,  3/4/5,  6,  7/8 ]+		--       1 * 2 * 3/4/5 * 6 * 7/8  		return $ \varlookup -> foldl1 mult $ map ( (foldl1 div) . (map ($varlookup) ) ) exprs; 	) <?> "multiplication/division") 	<|>try (expression $ n+1)+expression n@6 =+	let +		omod (ONum a) (ONum b) = ONum $ fromIntegral $ mod (floor a) (floor b)+		omod a        b        = errorAsAppropriate "modulo" a b+	in try (( do +		exprs <- sepBy1 (expression $ n+1) (many space >> string "%" >> many space)+		return $ \varlookup -> foldl1 omod $ map ($varlookup) exprs;+	) <?> "modulo") +	<|>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+		append a           b           = errorAsAppropriate "append" a b 	in try (( do -		exprs <- sepBy1 (expression $ n+1) (string "++")+		exprs <- sepBy1 (expression $ n+1) (many space >> string "++" >> many space) 		return $ \varlookup -> foldl1 append $ map ($varlookup) exprs; 	) <?> "append")  	<|>try (expression $ n+1)@@ -166,13 +224,18 @@ 	let  		add (ONum a) (ONum b) = ONum (a+b) 		add (OList a) (OList b) = OList $ zipWith add a b-		add _ _ = OUndefined+		add a b = errorAsAppropriate "add" a b  		sub (ONum a) (ONum b) = ONum (a-b) 		sub (OList a) (OList b) = OList $ zipWith sub a b-		sub _ _ = OUndefined+		sub a b = errorAsAppropriate "subtract" a b 	in try (( do -		exprs <- sepBy1 (sepBy1 (expression $ n+1) ( char '-')) (char '+')+		-- Similar to multiply & divide+		-- eg. "1+2+3-4-5+6-7" +		--     [[1],[2],[3,4,5],[6,7]]+		exprs <- sepBy1 (sepBy1 (pad $ expression $ n+1) +			(many space >> char '-' >> many space )) +			(many space >> char '+' >> many space) 		return $ \varlookup -> foldl1 add $ map ( (foldl1 sub) . (map ($varlookup) ) ) exprs; 	) <?> "addition/subtraction") 	<|>try (expression $ n+1)@@ -180,14 +243,43 @@ 	let 		negate (ONum n) = ONum (-n) 		negate (OList l) = OList $ map negate l-		negate _ = OUndefined+		negate a = OError ["Can't negate " ++ objTypeStr a ++ "(" ++ show a ++ ")"] 	in try (do 		char '-' 		many space 		expr <- expression $ n+1-		return $ \varlookup -> negate $ expr varlookup+		return $ negate . expr+	) <|> try (do+		char '+'+		many space+		expr <- expression $ n+1+		return $ expr 	) <|> try (expression $ n+1) expression n@2 = try (expression $ n+1)-expression n@1 = try (expression $ n+1)+expression n@1 = +	try ( do+		let +			numCompareToExprCompare f a b varlookup =+				case (fromOObj (a varlookup) :: Maybe ℝ, fromOObj (b varlookup) :: Maybe ℝ) of+					(Just a, Just b) -> f a b+					_ -> False+			numericComparisons = fmap numCompareToExprCompare $+				    (try $ string "==" >> return (==) )+				<|> (try $ string "!=" >> return (/=) )+				<|> (try $ string ">=" >> return (>=) )+				<|> (try $ string "<=" >> return (<=) )+				<|> (try $ string ">"  >> return (>)  )+				<|> (try $ string "<"  >> return (<)  )+		firstExpr <- expression $ n+1+		otherExpr <- many $ do+			comparison <- numericComparisons+			expr <- expression $ n+1+			return (comparison, expr)+		return $ if null otherExpr then firstExpr else fmap toOObj $ fst $ foldl +			(\(bstart, prevExpr) (comp, nextExpr) -> +				(\vlookup -> bstart vlookup && comp prevExpr nextExpr vlookup, nextExpr) )+			(\vlookup -> True, firstExpr)+			otherExpr+	)<|> 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
@@ -7,123 +7,368 @@ -- 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!!!+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ScopedTypeVariables  #-} -module Graphics.Implicit.ExtOpenScad.Primitives where+module Graphics.Implicit.ExtOpenScad.Primitives (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)+import Graphics.Implicit.ExtOpenScad.Util.ArgParser+import Graphics.Implicit.ExtOpenScad.Util.Computation +import qualified Graphics.Implicit.Primitives as Prim+import Data.Maybe (fromMaybe, isNothing)+import qualified Graphics.Implicit.SaneOperators as S++primitives :: [(String, [ComputationStateModifier] ->  ArgParser ComputationStateModifier)]+primitives = [ sphere, cube, square, cylinder, circle, polygon, union, difference, intersect, translate, scale, rotate, extrude, pack, shell ]++moduleWithSuite name modArgMapper = (name, modArgMapper)+moduleWithoutSuite name modArgMapper = (name, \suite -> modArgMapper)++ -- **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+	example "sphere(3);"+	example "sphere(r=5);" 	-- 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";+	r :: ℝ <- argument "r" +	            `doc` "radius of the sphere" 	-- So what does this module do? 	-- It adds a 3D object, a sphere of radius r, 	-- using the sphere implementation in Prim 	-- (Graphics.Implicit.Primitives)-	addObj3 $ Prim.sphere r;+	addObj3 $ Prim.sphere r  cube = moduleWithoutSuite "cube" $ do-	size <- argument "size";-	center <- boolArgumentWithDefault "center" False;-	r  <- realArgumentWithDefault "r" 0;++	-- examples+	example "cube(size = [2,3,4], center = true, r = 0.5);"+	example "cube(4);"++	-- arguments+	size   :: Either ℝ ℝ3  <- argument "size"+	                    `doc` "cube size"+	center :: Bool <- argument "center" +	                    `doc` "should center?"  +	                    `defaultTo` False+	r      :: ℝ    <- argument "r"+	                    `doc` "radius of rounding" +	                    `defaultTo` 0++	-- Tests+	test "cube(4);"+		`eulerCharacteristic` 2+	test "cube(size=[2,3,4]);"+		`eulerCharacteristic` 2++	-- A helper function for making rect3's accounting for centerdness+	let rect3 x y z = +		if center  +		then Prim.rect3R r (-x/2, -y/2, -z/2) (x/2, y/2, z/2)+		else Prim.rect3R r (0, 0, 0)  (x, y, z)+ 	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;+		Right (x,y,z) -> addObj3 $ rect3 x y z+		Left   w      -> addObj3 $ rect3 w w w --- What about $fn for regular n-gon prisms? This will break models..+++square = moduleWithoutSuite "square" $ do++	-- examples +	example "square(size = [3,4], center = true, r = 0.5);"+	example "square(4);"++	-- arguments+	size   :: Either ℝ ℝ2  <- argument "size"+	                    `doc`  "square size"+	center :: Bool <- argument "center" +	                    `doc` "should center?"  +	                    `defaultTo` False+	r      :: ℝ    <- argument "r"+	                    `doc` "radius of rounding" +	                    `defaultTo` 0++	-- Tests+	test "square(2);"+		`eulerCharacteristic` 0+	test "square(size=[2,3]);"+		`eulerCharacteristic` 0++	-- A helper function for making rect2's accounting for centerdness+	let rect x y = +		if center  +		then Prim.rectR r (-x/2, -y/2) (x/2, y/2)+		else Prim.rectR r (  0,    0 ) ( x,   y )++	-- caseOType matches depending on whether size can be coerced into+	-- the right object. See Graphics.Implicit.ExtOpenScad.Util+	case size of+		Left   w    -> addObj2 $ rect w w+		Right (x,y) -> addObj2 $ rect x y+++ 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 +	example "cylinder(r=10, h=30, center=true);"+	example "cylinder(r1=4, r2=6, h=10);"+	example	"cylinder(r=5, h=10, $fn = 6);" +	-- arguments+	r      :: ℝ    <- argument "r"+				`defaultTo` 1+				`doc` "radius of cylinder"+	h      :: ℝ    <- argument "h"+				`defaultTo` 1+				`doc` "height of cylinder"+	r1     :: ℝ    <- argument "r1"+				`defaultTo` 1+				`doc` "bottom radius; overrides r"+	r2     :: ℝ    <- argument "r2"+				`defaultTo` 1+				`doc` "top radius; overrides r"+	fn     :: ℕ    <- argument "$fn"+				`defaultTo` (-1)+				`doc` "number of sides, for making prisms"+	center :: Bool <- argument "center"+				`defaultTo` False+				`doc` "center cylinder with respect to z?"++	-- Tests+	test "cylinder(r=10, h=30, center=true);"+		`eulerCharacteristic` 0+	test "cylinder(r=5, h=10, $fn = 6);"+		`eulerCharacteristic` 0++	-- The result is a computation state modifier that adds a 3D object, +	-- based on the args.+	addObj3 $ if r1 == 1 && r2 == 1+		then let+			obj2 = if fn  < 0 then Prim.circle r else Prim.polygonR 0 $+				let sides = fromIntegral fn +				in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]]+			obj3 = Prim.extrudeR 0 obj2 h+		in if center+			then Prim.translate (0,0,-h/2) obj3+			else obj3+		else if center+			then  Prim.translate (0,0,-h/2) $ Prim.cylinder2 r1 r2 h+			else Prim.cylinder2  r1 r2 h+ circle = moduleWithoutSuite "circle" $ do-	r  <- realArgument "r";-	fn <- intArgumentWithDefault "$fn" (-1);+	+	example "circle(r=10); // circle"+	example "circle(r=5, $fn=6); //hexagon"++	-- Arguments+	r  :: ℝ <- argument "r"+		`doc` "radius of the circle"+	fn :: ℕ <- argument "$fn" +		`doc` "if defined, makes a regular polygon with n sides instead of a circle"+		`defaultTo` (-1)++	test "circle(r=10);"+		`eulerCharacteristic` 0+ 	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+		else addObj2 $ Prim.polygonR 0 $+			let sides = fromIntegral fn +			in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]] -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)+polygon = moduleWithoutSuite "polygon" $ do+	+	example "polygon ([(0,0), (0,10), (10,0)]);"+	+	points :: [ℝ2] <-  argument "points" +	                    `doc` "vertices of the polygon"+	paths :: [ℕ ]  <- argument "paths" +	                    `doc` "order to go through vertices; ignored for now"+	                    `defaultTo` []+	r      :: ℝ     <- argument "r"+	                    `doc` "rounding of the polygon corners; ignored for now"+	                    `defaultTo` 0+	case paths of+		[] -> addObj2 $ Prim.polygonR 0 points 		_ -> noChange;  -polygon = moduleWithoutSuite "polygon" $ do-	points <- argument "points";-	pathes <- argumentWithDefault "pathes" (OUndefined);+++union = moduleWithSuite "union" $ \suite -> do+	r :: ℝ <- argument "r"+		`defaultTo` 0.0+		`doc` "Radius of rounding for the union interface"+	if r > 0+		then getAndCompressSuiteObjs suite (Prim.unionR r) (Prim.unionR r)+		else getAndCompressSuiteObjs suite Prim.union Prim.union++intersect = moduleWithSuite "intersection" $ \suite -> do+	r :: ℝ <- argument "r"+		`defaultTo` 0.0+		`doc` "Radius of rounding for the intersection interface"+	if r > 0+		then getAndCompressSuiteObjs suite (Prim.intersectR r) (Prim.intersectR r)+		else getAndCompressSuiteObjs suite Prim.intersect Prim.intersect++difference = moduleWithSuite "difference" $ \suite -> do+	r :: ℝ <- argument "r"+		`defaultTo` 0.0+		`doc` "Radius of rounding for the difference interface"+	if r > 0+		then getAndCompressSuiteObjs suite (Prim.differenceR r) (Prim.differenceR r)+		else getAndCompressSuiteObjs suite Prim.difference Prim.difference++translate = moduleWithSuite "translate" $ \suite -> do++	example "translate ([2,3]) circle (4);"+	example "translate ([5,6,7]) sphere(5);"++	v :: Either ℝ (Either ℝ2 ℝ3) <- argument "v"+		`doc` "vector to translate by"+	+	let +		translateObjs shift2 shift3 = +			getAndTransformSuiteObjs suite (Prim.translate shift2) (Prim.translate shift3)+	+	case v of+		Left   x              -> translateObjs (x,0) (x,0,0)+		Right (Left (x,y))    -> translateObjs (x,y) (x,y,0.0)+		Right (Right (x,y,z)) -> translateObjs (x,y) (x,y,z)++deg2rad x = x / 180.0 * pi++-- This is mostly insane+rotate = moduleWithSuite "rotate" $ \suite -> do+	a <- argument "a"+		`doc` "value to rotate by; angle or list of angles"++	-- caseOType matches depending on whether size can be coerced into+	-- the right object. See Graphics.Implicit.ExtOpenScad.Util+	-- Entries must be joined with the operator <||>+	-- Final entry must be fall through.+	caseOType a $+		       ( \xy  ->+			getAndTransformSuiteObjs suite (Prim.rotate $ deg2rad xy ) (Prim.rotate3 (deg2rad xy, 0, 0) )+		) <||> ( \(yz,xy,xz) ->+			getAndTransformSuiteObjs suite (Prim.rotate $ deg2rad xy ) (Prim.rotate3 (deg2rad yz, deg2rad xz, deg2rad xy) )+		) <||> ( \(yz,xz) ->+			getAndTransformSuiteObjs suite (id ) (Prim.rotate3 (deg2rad yz, deg2rad xz, 0))+		) <||> ( \_  -> noChange )+++scale = moduleWithSuite "scale" $ \suite -> do++	example "scale(2) square(5);"+	example "scale([2,3]) square(5);"+	example "scale([2,3,4]) cube(5);"++	v :: Either ℝ (Either ℝ2 ℝ3) <- argument "v"+		`doc` "vector or scalar to scale by"+	 	let-		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+		scaleObjs strech2 strech3 = +			getAndTransformSuiteObjs suite (Prim.scale strech2) (Prim.scale strech3)+	+	case v of+		Left   x              -> scaleObjs (x,0) (x,0,0)+		Right (Left (x,y))    -> scaleObjs (x,y) (x,y,0.0)+		Right (Right (x,y,z)) -> scaleObjs (x,y) (x,y,z) -		extractNumList :: [OpenscadObj] -> Maybe [ℝ]-		extractNumList [] = Just []-		extractNumList ((ONum n):others) = -			case extractNumList others of-				Just l -> Just $ n:l-				Nothing -> Nothing-		extractNumList _ = Nothing+extrude = moduleWithSuite "linear_extrude" $ \suite -> do+	example "extrude(10) square(5);" -		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;+	height :: Either ℝ (ℝ -> ℝ -> ℝ) <- argument "height" `defaultTo` (Left 1)+		`doc` "height to extrude to..."+	center :: Bool <- argument "center" `defaultTo` False+		`doc` "center? (the z component)"+	twist  :: Maybe (Either ℝ (ℝ  -> ℝ)) <- argument "twist"  `defaultTo` Nothing+		`doc` "twist as we extrude, either a total amount to twist or a function..."+	scale  :: Maybe (Either ℝ (ℝ  -> ℝ)) <- argument "scale"  `defaultTo` Nothing+		`doc` "scale according to this funciton as we extrud..."+	translate :: Maybe (Either ℝ2 (ℝ -> ℝ2)) <- argument "translate"  `defaultTo` Nothing+		`doc` "translate according to this funciton as we extrude..."+	r      :: ℝ   <- argument "r"      `defaultTo` 0+		`doc` "round the top?"+	+	let+		degRotate = (\θ (x,y) -> (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ))) . (*(2*pi/360)) +		heightn = case height of+				Left  h -> h+				Right f -> f 0 0 +		height' = case height of+			Right f -> Right $ uncurry f+			Left a -> Left a++		shiftAsNeeded =+			if center+			then Prim.translate (0,0,-heightn/2.0)+			else id+		+		funcify :: S.Multiplicative ℝ a a => Either a (ℝ -> a) -> ℝ -> a+		funcify (Left val) h = (h/heightn) S.* val+		funcify (Right f ) h = f h+		+		twist' = fmap funcify twist+		scale' = fmap funcify scale+		translate' = fmap funcify translate 	+	getAndModUpObj2s suite $ \obj -> case height of+		Left constHeight | isNothing twist && isNothing scale && isNothing translate ->+			shiftAsNeeded $ Prim.extrudeR r obj constHeight+		_ -> +			shiftAsNeeded $ Prim.extrudeRM r twist' scale' translate' obj height'+++{-rotateExtrudeStatement = moduleWithSuite "rotate_extrude" $ \suite -> do+	h <- realArgument "h"+	center <- boolArgumentWithDefault "center" False+	twist <- realArgumentWithDefault 0.0+	r <- realArgumentWithDefault "r" 0.0+	getAndModUpObj2s suite (\obj -> Prim.extrudeRMod r (\θ (x,y) -> (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ)) )  obj h) +-}++shell = moduleWithSuite "shell" $ \suite -> do+	w :: ℝ <- argument "w"+			`doc` "width of the shell..."+	+	getAndTransformSuiteObjs suite (Prim.shell w) (Prim.shell w)++-- Not a perenant solution! Breaks if can't pack.+pack = moduleWithSuite "pack" $ \suite -> do++	example "pack ([45,45], sep=2) { circle(10); circle(10); circle(10); circle(10); }"++	-- arguments+	size :: ℝ2 <- argument "size"+		`doc` "size of 2D box to pack objects within"+	sep  :: ℝ  <- argument "sep"+		`doc` "mandetory space between objects"++	-- The actual work...+	return $  \ ioWrappedState -> do+		(varlookup,  obj2s,  obj3s)  <- ioWrappedState+		(varlookup2, obj2s2, obj3s2) <- runComputations (return (varlookup, [], [])) suite+		if not $ null obj3s2+			then case Prim.pack3 size sep obj3s2 of+				Just solution -> return (varlookup2, obj2s, obj3s ++ [solution] )+				Nothing       -> do +					putStrLn "Can't pack given objects in given box with present algorithm"+					return (varlookup2, obj2s, obj3s)+			else case Prim.pack2 size sep obj2s2 of+				Just solution -> return (varlookup2, obj2s ++ [solution], obj3s)+				Nothing       -> do +					putStrLn "Can't pack given objects in given box with present algorithm"+					return (varlookup2, obj2s, obj3s)+
Graphics/Implicit/ExtOpenScad/Statements.hs view
@@ -1,5 +1,3 @@-- -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU GPL, see LICENSE @@ -7,19 +5,26 @@  -- Implement statements for things other than primitive objects! +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ScopedTypeVariables, NoMonomorphismRestriction  #-}+ module Graphics.Implicit.ExtOpenScad.Statements where  import Prelude hiding (lookup) import Graphics.Implicit.Definitions+import Graphics.Implicit.ObjectUtil (getBox2, getBox3) 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 qualified Graphics.Implicit.Primitives as Prim+import Data.Map (Map, lookup, insert, union) import Text.ParserCombinators.Parsec  import Text.ParserCombinators.Parsec.Expr import Control.Monad (liftM)+import System.Plugins.Load (load_, LoadStatus(..))+import Control.Monad (forM_)+import Graphics.Implicit.ExtOpenScad.Util.ArgParser+import Graphics.Implicit.ExtOpenScad.Util.Computation  tryMany = (foldl1 (<|>)) . (map try) @@ -30,15 +35,17 @@ 		many space 		s <- tryMany [ 			ifStatement,-			forStatement, -			unionStatement,-			intersectStatement,-			differenceStatement,-			translateStatement,-			rotateStatement,-			scaleStatement,-			extrudeStatement,-			shellStatement+			forStatement,+			throwAway,+			userModuleDeclaration,+			unimplemented "mirror",+			unimplemented "multmatrix",+			unimplemented "color",+			unimplemented "render",+			unimplemented "surface",+			unimplemented "projection",+			unimplemented "rotate_extrude",+			unimplemented "import_stl" 			-- rotateExtrudeStatement 			] 		many space@@ -49,19 +56,19 @@ 			echoStatement, 			assigmentStatement, 			includeStatement,-			useStatement,-			sphere,-			cube,-			square,-			cylinder,-			circle,-			polygon+			useStatement 			] 		many space 		char ';' 		many space 		return s-	)<|> (many space >> comment)+	)<|> (try $ many space >> comment)+	<|> (try $ do+		many space+		s <- userModule+		many space+		return s+	)   @@ -91,10 +98,6 @@ 	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 = @@ -107,9 +110,18 @@ 		manyTill anyChar (try $ string "*/") 	)) >> return id) <?> "comment" +throwAway :: GenParser Char st ComputationStateModifier+throwAway = do+	many space+	oneOf "%*"+	many space+	computationStatement+	return id+ -- An included statement! Basically, inject another openscad file here... includeStatement :: GenParser Char st ComputationStateModifier includeStatement = (do+	line <- fmap sourceLine getPosition 	string "include" 	many space 	string "<"@@ -117,19 +129,33 @@ 	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+		case reverse filename of+			'o':'.':_ -> do+				loaded :: LoadStatus VariableLookup+					<- load_ filename ["."] "openscadAPI"+				case loaded of+					LoadFailure errs -> do+						putStrLn $ show errs+						return state+					LoadSuccess _ newapi -> do+						putStrLn "Loaded Haskell Module..."+						return (union varlookup newapi, obj2s, obj3s)+			_ -> do+				content <- readFile filename+				case parse (many1 computationStatement) ""  content of+					Left  err ->  do+						errorMessage line $ +							"Error parsing included file <file>" ++ filename ++ "</file>\n"+							++ show err+							++ "Ignoring included file <file>" ++ filename ++ "</file>..."+						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+	line <- fmap sourceLine getPosition 	string "use" 	many space 	string "<"@@ -140,9 +166,10 @@ 		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 ++ "..."+				errorMessage line $ +					"Error parsing included file <file>" ++ filename ++ "</file>\n"+					++ show err+					++ "Ignoring included file <file>" ++ filename ++ "</file>..." 				return state 			Right result -> runComputations (return (varlookup,[],[])) result 	) <?> "use statement"@@ -152,18 +179,32 @@ assigmentStatement :: GenParser Char st ComputationStateModifier assigmentStatement =  	(try $ do-		varSymb <- variableSymb+		line <- fmap sourceLine getPosition+		pattern <- patternMatcher 		many space 		char '=' 		many space 		valExpr <- expression 0 		return $ \ ioWrappedState -> do-			(varlookup, obj2s, obj3s) <- ioWrappedState+			state@(varlookup, obj2s, obj3s) <- ioWrappedState 			let 				val = valExpr varlookup-			return (insert varSymb val varlookup, obj2s, obj3s) +				match = pattern val+			case match of+				Just dictWithNew -> case val of+					OError e -> do+						errorMessage line $ +							"error in evaluating assignment statement assigned value:"+							++ concat (map ("\n   "++) e)+						return (union dictWithNew varlookup, obj2s, obj3s) +					_ -> return (union dictWithNew varlookup, obj2s, obj3s) +				Nothing -> do+					errorMessage line $ "pattern match fail in assignment statement"+					return state 	) <|> (try $ do -		varSymb <- variableSymb+		line <- fmap sourceLine getPosition+		varSymb <- (try $ string "function" >> many1 space >> variableSymb) +		            <|> variableSymb 		many space 		char '(' 		many space@@ -181,25 +222,49 @@ 					\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)+			case val of+				OError e -> do+					errorMessage line $ "error in evaluating assignment statement assigned value:"+						++ concat (map ("\n   "++) e)+					return (insert varSymb val varlookup, obj2s, obj3s)+				_ -> return (insert varSymb val varlookup, obj2s, obj3s) 	)<?> "assignment statement"  -- | An echo statement (parser) echoStatement :: GenParser Char st ComputationStateModifier echoStatement = do+	line <- fmap sourceLine getPosition 	string "echo" 	many space 	char '(' 	many space-	val <- expression 0+	exprs <- expression 0 `sepBy` (many space >> char ',' >> many space) 	many space 	char ')' 	return $  \ ioWrappedState -> do 		state@(varlookup, _, _) <- ioWrappedState-		putStrLn $ show $ val varlookup+		let +			vals = map ($varlookup) exprs+			isError (OError _) = True+			isError _ = False+			show2 (OString str) = str+			show2 a = show a+		errorMessage line $ +			if any isError vals +			then +				"in module <module>echo</module>:"+				++ ( concat $ concat $ +					map (map ("\n   "++)) $ +						map (\(OError errs) -> errs) $ filter isError vals+				   )+			else+				unwords $ map show2 vals+ 		return state +ifStatement :: GenParser Char st ComputationStateModifier ifStatement = (do+	line <- fmap sourceLine getPosition 	string "if" 	many space 	char '('@@ -211,22 +276,33 @@ 	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+		case bexpr varlookup of+			OBool bval -> +				if bval+				then runComputations (return state) statementsTrueCase+				else runComputations (return state) statementsFalseCase+			OError errs -> do+				errorMessage line $ " error while evaluating if statement conditional:" +				         ++ concat (map ("\n    " ++) errs)+				return state+			obj -> do+				errorMessage line $ "inappropriate type for if statement conditional:\n"+				        ++ "   value " ++ show obj ++ " is not a boolean."+				return state 	) <?> "if statement" +forStatement :: GenParser Char st ComputationStateModifier forStatement = (do+	line <- fmap sourceLine getPosition 	-- a for loop is of the form: 	--      for ( vsymb = vexpr   ) loopStatements-	-- eg.  for ( a     = [1,2,3] ) {echo(a); echo "lol";}+	-- eg.  for ( a     = [1,2,3] ) {echo(a);   echo "lol";}+	-- eg.  for ( [a,b] = [[1,2]] ) {echo(a+b); echo "lol";} 	string "for" 	many space 	char '(' 	many space-	vsymb <- variableSymb+	pattern <- patternMatcher 	many space 	char '=' 	vexpr <- expression 0@@ -243,20 +319,34 @@ 				-> OpenscadObj      -- ^ The value of vsymb for this iteration 				-> ComputationState -- ^ The resulting state 			loopOnce ioWrappedState val =  do-				(varlookup, a, b) <- ioWrappedState;+				state@(varlookup, a, b) <- ioWrappedState; 				let-					vsymbSetState = return (insert vsymb val varlookup, a, b)+					match = pattern val+					vsymbSetState = case match of+						Just dictWithNew -> return (union dictWithNew varlookup, a, b) +						Nothing -> do+							errorMessage line $ "Pattern match fail in for loop step"+							return state 				runComputations vsymbSetState loopStatements 		-- Then loops once for every entry in vexpr-		foldl (loopOnce) (return state) $ case vexpr varlookup of -			OList l -> l;-			_       -> [];+		case vexpr varlookup of +			OList l -> foldl (loopOnce) (return state) l+			OError errs -> do+				errorMessage line $ "Error while evaluating for loop array:" +				         ++ concat (map ("\n    " ++) errs)+				return state+			obj     -> do+				errorMessage line $ "Error in for loop iteration array:\n"+				        ++ "   Inappropriate type for loop iterated array:\n"+				        ++ "       value " ++ show obj ++ " is not a list."+				return state 	) <?> "for statement"  moduleWithSuite :: 	String -> ([ComputationStateModifier] -> ArgParser ComputationStateModifier) 	-> GenParser Char st ComputationStateModifier moduleWithSuite name argHandeler = (do+	line <- fmap sourceLine getPosition 	string name; 	many space; 	(unnamed, named) <- moduleArgsUnit@@ -268,144 +358,125 @@ 			(map ($varlookup) unnamed)  			(map (\(a,b) -> (a, b varlookup)) named) (argHandeler statements) 			of-				Just computationModifier ->  computationModifier (return state)-				Nothing -> (return state);+				(Just computationModifier, []) ->  computationModifier (return state)+				(Nothing, []) -> do+					errorMessage line $ "Module <module>" ++ name +						++ "</module> failed without a message"+					return state+				(Nothing, errs) -> do+					errorMessage line $  "Module <module>" ++ name +						++ "</module> failed with the following messages:"+						++ concat (map ("  "++) errs)+					return state+				(Just computationModifier, errs) -> do+					errorMessage line $ "Module <module>" ++ name +						++ "</module> gave the following warnings:"+						++ concat (map ("  "++) errs)+					computationModifier (return state) 	) <?> (name ++ " statement") +unimplemented :: String -> GenParser Char st ComputationStateModifier+unimplemented name = do+	line <- fmap sourceLine getPosition+	string name+	many space;+	moduleArgsUnit+	many space;+	(try suite <|> (many space >> char ';' >> return []))+	return $ \ ioWrappedState -> do+		state <- ioWrappedState+		errorMessage line $ "OpenSCAD command " ++ name ++ " not yet implemented"+		return state -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)   )+userModule :: GenParser Char st ComputationStateModifier+userModule = do+	line <- fmap sourceLine getPosition+	name <- variableSymb;+	many space;+	(unnamed, named) <- moduleArgsUnit+	many space;+	statements <- ( try suite <|> (many space >> char ';' >> return []))+	return $ \ ioWrappedState -> do+		state@(varlookup, obj2s, obj3s) <- ioWrappedState+		case lookup name varlookup of+			Just (OModule m) -> +				case argMap +					(map ($varlookup) unnamed) +					(map (\(a,b) -> (a, b varlookup)) named) +					(m statements)+				of+				(Just computationModifier, []) ->  +					computationModifier (return state)+				(Nothing, []) -> do+					errorMessage line $ "Module <module>" ++ name +						++ "</module> failed without a message"+					return state+				(Nothing, errs) -> do+					errorMessage line $  "Module <module>" ++ name +						++ "</module> failed with the following messages:"+						++ concat (map ("  "++) errs)+					return state+				(Just computationModifier, errs) -> do+					errorMessage line $ "Module <module>" ++ name +						++ "</module> gave the following warnings:"+						++ concat (map ("  "++) errs)+					computationModifier (return state)+			_ -> do+				errorMessage line $  "module <module>" ++ name ++ "</module> is not in scope"+				return state  -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+userModuleDeclaration :: GenParser Char st ComputationStateModifier+userModuleDeclaration = do+	string "module"+	many space;+	newModuleName <- variableSymb;+	many space;+	args <- moduleArgsUnitDecl+	many space;+	codeStatements <- suite+	return $ \ envIOWrappedState -> do+		(envVarlookup, envObj2s, envObj3s) <- envIOWrappedState+		let +			newModule = OModule $ \childrenStatements -> do +				argVarlookupModifier <- args envVarlookup+				return $ \contextIOWrappedState -> do+					contextState@(contextVarLookup, contextObj2s, contextObj3s)+						<- contextIOWrappedState+					(_, childObj2s, childObj3s) <- runComputations +						(return contextState)+						childrenStatements;+					let+						children = ONum $ fromIntegral  +							(length childObj2s + length childObj3s)+						child = OModule $ \suite -> do+							n :: ℕ <- argument "n";+							if n <= length childObj3s +							         then addObj3 (childObj3s !! n)+							         else addObj2 (childObj2s !! (n+1-length childObj3s))+						childBox = OFunc $ \n -> case fromOObj n :: Maybe ℕ of+							Just n  | n < length childObj3s + length childObj2s ->  +								if n <= length childObj3s +							         then toOObj $ getBox3 (childObj3s !! n)+							         else toOObj $ getBox2 (childObj2s !! (n+1-length childObj3s))+							Nothing -> OUndefined+						varlookupForCode = +							(insert "child" child) $ +							(insert "children" children) $+							(insert "childBox" childBox) $+							(insert newModuleName newModule) $+							envVarlookup+					(_, resultObj2s, resultObj3s) +						<- runComputations +							(return (argVarlookupModifier varlookupForCode,[],[]))+							codeStatements+					return (+						contextVarLookup, +						contextObj2s ++ resultObj2s, +						contextObj3s ++ resultObj3s+						)+		return (insert newModuleName (newModule) envVarlookup, envObj2s, envObj3s)  -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
@@ -1,82 +1,46 @@+-- 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.+++{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ScopedTypeVariables  #-}+ 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 Graphics.Implicit.ExtOpenScad.Util.ArgParser import Data.Map (Map, lookup, insert)+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe import qualified Data.List import Text.ParserCombinators.Parsec  import Text.ParserCombinators.Parsec.Expr-import Control.Monad (liftM)+import Data.Maybe (isJust,isNothing)+import Control.Monad (forM_) -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)+type Any = OpenscadObj -addObj3 :: (Monad m) => Obj3Type -> m ComputationStateModifier-addObj3 obj = return $  \ ioWrappedState -> do-		(varlookup, obj2s, obj3s) <- ioWrappedState-		return (varlookup, obj2s, obj3s ++ [obj])+caseOType = flip ($) -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)+infixr 2 <||> -runIO ::  (Monad m) => IO() -> m ComputationStateModifier-runIO newio = return $  \ ioWrappedState -> do-		state <- ioWrappedState-		newio-		return state+(<||>) :: forall desiredType out. (OTypeMirror desiredType)+	=> (desiredType -> out) +	-> (OpenscadObj -> out)+	-> (OpenscadObj -> out) -noChange :: (Monad m) => m ComputationStateModifier-noChange = return id+(<||>) f g = \input ->+	let+		coerceAttempt = fromOObj input :: Maybe desiredType+	in +		if isJust coerceAttempt -- ≅ (/= Nothing) but no Eq req+		then f $ (\(Just a) -> a) coerceAttempt+		else g input  moduleArgsUnit ::   	GenParser Char st ([VariableLookup -> OpenscadObj], [(String, VariableLookup -> OpenscadObj)])@@ -84,14 +48,14 @@ 	char '('; 	many space; 	args <- sepBy ( -		(try $ do+		(try $ do -- eg. a = 12 			symb <- variableSymb; 			many space; 			char '='; 			many space; 			expr <- expression 0; 			return $ Right (symb, expr);-		) <|> (try $ do+		) <|> (try $ do -- eg. a(x,y) = 12 			symb <- variableSymb; 			many space; 			char '('@@ -108,7 +72,7 @@ 				makeFunc baseExpr [] varlookup' = baseExpr varlookup' 				funcExpr = makeFunc expr argVars 			return $ Right (symb, funcExpr);-		) <|> (do {+		) <|> (do { -- eg. 12 			expr <- expression 0; 			return $ Left expr; 		})@@ -122,23 +86,56 @@ 		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;+moduleArgsUnitDecl ::  +	GenParser Char st (VariableLookup -> ArgParser (VariableLookup -> VariableLookup))+moduleArgsUnitDecl = do+	char '('; 	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+	args <- sepBy ( +		(try $ do+			symb <- variableSymb;+			many space;+			char '=';+			many space;+			expr <- expression 0;+			return $ \varlookup -> +				ArgParser symb (Just$ expr varlookup) "" (\val -> return $ insert symb val);+		) <|> (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 $ \varlookup ->+ 				ArgParser symb (Just$ funcExpr varlookup) "" (\val -> return $ insert symb val);+		) <|> (do {+			vsymb <- variableSymb;+			return $ \varlookup ->+ 				ArgParser vsymb Nothing "" (\val -> return $ insert vsymb val);+		})+		) (many space >> char ',' >> many space);+	many space;	+	char ')';+	let+		merge :: +			(ArgParser (VariableLookup -> VariableLookup))+			->  (ArgParser (VariableLookup -> VariableLookup))+			->  (ArgParser (VariableLookup -> VariableLookup))+		merge a b = do+			a' <- a+			b' <- b+			return (b'.a')+	return $ \varlookup -> foldl merge (return id) $ map ($varlookup) $ args   pad parser = do@@ -147,4 +144,33 @@ 	many space 	return a +++patternMatcher :: GenParser Char st (OpenscadObj -> Maybe VariableLookup)+patternMatcher =+	(do +		char '_'+		return (\obj -> Just Map.empty)+	) <|> ( do+		a <- literal+		return $ \obj ->+			if obj == (a undefined)+			then Just (Map.empty)+			else Nothing+	) <|> ( do+		symb <- variableSymb+		return $ \obj -> Just $ Map.singleton symb obj+	) <|> ( do+		char '['+		many space+		components <- patternMatcher `sepBy` (many space >> char ',' >> many space)+		many space+		char ']'+		return $ \obj -> case obj of+			OList l -> +				if length l == length components+				then fmap Map.unions $ sequence $ zipWith ($) components l+				else Nothing+			_ -> Nothing+	)
+ Graphics/Implicit/ExtOpenScad/Util/ArgParser.hs view
@@ -0,0 +1,186 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ScopedTypeVariables  #-}++-- | We're going to give ourselves all sorts of goodies to parse OpenSCAD style module arguments here!!!+--   To see the awesomeness of this applied, look at Primitives+--   +--   Our tool of choice is ArgParser. +--   It handles argument input, but also examples and unit tests for modules++module Graphics.Implicit.ExtOpenScad.Util.ArgParser (++	-- $ Note: The actual definition of ArgParser is in Defintions, +	--   to avoid the pain of circular dependencies.++	-- * ArgParser building functions+	-- ** argument & combinators+	argument,+	doc,+	defaultTo,+	-- ** example+	example,+	-- ** test & combinators+	test,+	eulerCharacteristic,++	-- * Tools for handeling ArgParsers	+	argMap,+	getArgParserDocs,+	Doc (..), DocPart (..)++	)where++import Graphics.Implicit.ExtOpenScad.Definitions++import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import qualified Control.Exception as Ex++--  * Instance Declarations++-- | ArgParser is a monad.+--   In some ways, an applicative functor would be nicer -- extracting docs +--   would be less crazy --,  but we want do notation for prettiness.++instance Monad ArgParser where++	-- return is easy: if we want an ArgParser that just gives us a, that is +	-- ArgParserTerminator a+	return a = ArgParserTerminator a++	-- Now things get more interesting. We need to describe how (>>=) works.+	-- Let's get the hard ones out of the way first.+	-- ArgParser actually +	(ArgParser str fallback doc f) >>= g = ArgParser str fallback doc (\a -> (f a) >>= g)+	(ArgParserFailIf b errmsg child) >>= g = ArgParserFailIf b errmsg (child >>= g)+	-- These next to is easy, they just pass the work along to their child+	(ArgParserExample str child) >>= g = ArgParserExample str (child >>= g)+	(ArgParserTest str tests child) >>= g = ArgParserTest str tests (child >>= g)+	-- And an ArgParserTerminator happily gives away the value it contains+	(ArgParserTerminator a) >>= g = g a++-- * ArgParser building functions++-- ** argument and combinators++argument :: forall desiredType. (OTypeMirror desiredType) => String -> ArgParser desiredType+argument name = +	ArgParser name Nothing "" $ \oObjVal -> do+		let+			val = fromOObj oObjVal :: Maybe desiredType+			errmsg = case oObjVal of+				OError errs -> "error in computing value for arugment " ++ name+				             ++ ": " ++ concat errs+				_   ->  "arg " ++ show oObjVal ++ " not compatible with " ++ name+		-- Using /= Nothing would require Eq desiredType+		ArgParserFailIf (Maybe.isNothing val) errmsg $ ArgParserTerminator $ (\(Just a) -> a) val++doc (ArgParser name defMaybeVal oldDoc next) doc =+	ArgParser name defMaybeVal doc next++defaultTo :: forall a. (OTypeMirror a) => ArgParser a -> a -> ArgParser a+defaultTo (ArgParser name oldDefMaybeVal doc next) newDefVal = +	ArgParser name (Just $ toOObj newDefVal) doc next++-- ** example++example :: String -> ArgParser ()+example str = ArgParserExample str (return ())++-- * test and combinators++test :: String -> ArgParser ()+test str = ArgParserTest str [] (return ())++eulerCharacteristic :: ArgParser a -> Int -> ArgParser a+eulerCharacteristic (ArgParserTest str tests child) χ =+	ArgParserTest str ((EulerCharacteristic χ) : tests) child++-- * Tools for handeling ArgParsers++-- | Apply arguments to an ArgParser++argMap :: +	   [OpenscadObj]            -- ^ Unnamed Arguments+	-> [(String, OpenscadObj)]  -- ^ Named Arguments+	-> ArgParser a              -- ^ ArgParser to apply them to+	-> (Maybe a, [String])      -- ^ (result, error messages)++argMap a b = argMap2 a (Map.fromList b)++++argMap2 :: [OpenscadObj] -> Map.Map String OpenscadObj -> ArgParser a -> (Maybe a, [String])++argMap2 unnamedArgs namedArgs (ArgParser name fallback _ f) = +	case Map.lookup name namedArgs of+		Just a -> argMap2 +			unnamedArgs +			(Map.delete name namedArgs) +			(f a)+		Nothing -> case unnamedArgs of+			x:xs -> argMap2 xs namedArgs (f x)+			[]   -> case fallback of+				Just b  -> argMap2 [] namedArgs (f b)+				Nothing -> (Nothing, ["No value and no default for argument " ++ name])++argMap2 a b (ArgParserTerminator val) = +	(Just val,+		if length a + Map.size b > 0+		then ["unused arguments"]+		else []+	)++argMap2 a b (ArgParserFailIf test err child) = +	if test +	then (Nothing, [err])+	else argMap2 a b child++argMap2 a b (ArgParserExample str child) = argMap2 a b child++argMap2 a b (ArgParserTest str tests child) = argMap2 a b child+++-- | We need a format to extract documentation into+data Doc = Doc String [DocPart]+             deriving (Show)++data DocPart = ExampleDoc String+             | ArgumentDoc String (Maybe String) String+             deriving (Show)+++--   Here there be dragons!+--   Because we made this a Monad instead of applicative functor, there's now sane way to do this.+--   We give undefined (= an error) and let laziness prevent if from ever being touched.+--   We're using IO so that we can catch an error if this backfires.+--   If so, we *back off*.++-- | Extract Documentation from an ArgParser++getArgParserDocs :: +	(ArgParser a)    -- ^ ArgParser+	-> IO [DocPart]  -- ^ Docs (sadly IO wrapped)++getArgParserDocs (ArgParser name fallback doc fnext) = +	do+		otherDocs <- Ex.catch (getArgParserDocs $ fnext undefined) (\(e :: Ex.SomeException) -> return [])+		return $ (ArgumentDoc name (fmap show fallback) doc):otherDocs++getArgParserDocs (ArgParserExample str child) =+	do+		childResults <- getArgParserDocs child+		return $ (ExampleDoc str) : childResults++-- We try to look at as little as possible, to avoid the risk of triggering an error.+-- Yay laziness!++getArgParserDocs (ArgParserTest   _ _ child ) = getArgParserDocs child+getArgParserDocs (ArgParserFailIf _ _ child ) = getArgParserDocs child++-- To look at this one would almost certainly be death (exception)+getArgParserDocs (ArgParserTerminator _ ) = return []++
+ Graphics/Implicit/ExtOpenScad/Util/Computation.hs view
@@ -0,0 +1,79 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ScopedTypeVariables  #-}++-- | Utilities for dealing with computations, in particular ComputationStateModifier++module Graphics.Implicit.ExtOpenScad.Util.Computation where++import Graphics.Implicit.Definitions+import Graphics.Implicit.ExtOpenScad.Definitions++-- | 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)++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++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)   )+
Graphics/Implicit/MathUtil.hs view
@@ -1,11 +1,37 @@ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU GPL, see LICENSE -module Graphics.Implicit.MathUtil (rmax, rmin, rmaximum, rminimum) where+module Graphics.Implicit.MathUtil (rmax, rmin, rmaximum, rminimum, distFromLineSeg, pack, box3sWithin) where  import Data.List import Graphics.Implicit.Definitions+import qualified Graphics.Implicit.SaneOperators as S +-- | The distance a point p is from a line segment (a,b)+distFromLineSeg :: ℝ2 -> (ℝ2, ℝ2) -> ℝ+distFromLineSeg p@(p1,p2) (a@(a1,a2), b@(b1,b2)) = S.norm (closest S.- p)+	where+		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++		++box3sWithin :: ℝ -> (ℝ3, ℝ3) -> (ℝ3,ℝ3) -> Bool+box3sWithin r ((ax1, ay1, az1),(ax2, ay2, az2)) ((bx1, by1, bz1),(bx2, by2, bz2)) =+	let+		near (a1, a2) (b1, b2) = not $ (a2 + r < b1) || (b2 + r < a1)+	in+		   (ax1,ax2) `near` (bx1, bx2)+		&& (ay1,ay2) `near` (by1, by2)+		&& (az1,az2) `near` (bz1, bz2)++ -- | Rounded Maximum -- Consider  max(x,y) = 0, the generated curve  -- has a square-like corner. We replace it with a @@ -58,4 +84,43 @@ 		tops = sort l 	in 		rmin r (tops !! 0) (tops !! 1)+++pack :: +	Box2           -- ^ The box to pack within+	-> ℝ           -- ^ The space seperation between items+	-> [(Box2, a)] -- ^ Objects with their boxes+	-> ([(ℝ2, a)], [(Box2, a)] ) -- ^ Packed objects with their positions, objects that could be packed++pack (dx, dy) sep objs = packSome sortedObjs (dx, dy)+	where+		compareBoxesByY  ((_, ay1), (_, ay2))  ((_, by1), (_, by2)) = +				compare (abs $ by2-by1) (abs $ ay2 - ay1)++		sortedObjs = sortBy +			(\(boxa, _) (boxb, _) -> compareBoxesByY boxa boxb ) +			objs++		tmap1 f (a,b) = (f a, b)+		tmap2 f (a,b) = (a, f b)++		--packSome :: [(Box2,a)] -> Box2 -> ([(ℝ2,a)], [(Box2,a)])+		packSome (presObj@(((x1,y1),(x2,y2)),obj):otherBoxedObjs) box@((bx1, by1), (bx2, by2)) = +			if abs (x2 - x1) <= abs (bx2-bx1) && abs (y2 - y1) <= abs (by2-by1)+			then +				let+					row = tmap1 (((bx1-x1,by1-y1), obj):) $+						packSome otherBoxedObjs ((bx1+x2-x1+sep, by1), (bx2, by1 + y2-y1))+					rowAndUp = +						if abs (by2-by1) - abs (y2-y1) > sep+						then tmap1 ((fst row) ++ ) $+							packSome (snd row) ((bx1, by1 + y2-y1+sep), (bx2, by2))+						else row+				in+					rowAndUp+			else+				tmap2 (presObj:) $ packSome otherBoxedObjs box+		packSome [] _ = ([], [])++
+ Graphics/Implicit/ObjectUtil.hs view
@@ -0,0 +1,12 @@+-- 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.ObjectUtil(getImplicit3, getImplicit2, getBox3, getBox2) where++import Graphics.Implicit.ObjectUtil.GetImplicit3+import Graphics.Implicit.ObjectUtil.GetImplicit2+import Graphics.Implicit.ObjectUtil.GetBox3+import Graphics.Implicit.ObjectUtil.GetBox2+
+ Graphics/Implicit/ObjectUtil/GetBox2.hs view
@@ -0,0 +1,107 @@+-- 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.ObjectUtil.GetBox2 (getBox2) where++import Prelude hiding ((+),(-),(*),(/))+import qualified Prelude as P+import Graphics.Implicit.SaneOperators+import Graphics.Implicit.Definitions+import qualified Graphics.Implicit.MathUtil as MathUtil+import Data.List (nub)++getBox2 :: SymbolicObj2 -> Box2++-- Primitives+getBox2 (RectR r a b) = (a,b)++getBox2 (Circle r ) =  ((-r, -r), (r,r))++getBox2 (PolygonR r points) = ((minimum xs, minimum ys), (maximum xs, maximum ys)) +	 where (xs, ys) = unzip points++-- (Rounded) CSG+getBox2 (Complement2 symbObj) = +	((-infty, -infty), (infty, infty)) where infty = (1::ℝ)/(0 ::ℝ)++getBox2 (UnionR2 r symbObjs) =+	let +		boxes = map getBox2 symbObjs+		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+	in+		((left-r,bot-r),(right+r,top+r))++getBox2 (DifferenceR2 r symbObjs) =+	let +		firstBox:_ = map getBox2 symbObjs+	in+		firstBox++getBox2 (IntersectR2 r symbObjs) = +	let +		boxes = map getBox2 symbObjs+		(leftbot, topright) = unzip boxes+		(lefts, bots) = unzip leftbot+		(rights, tops) = unzip topright+		left = maximum lefts+		bot = maximum bots+		right = minimum rights+		top = minimum tops+	in+		((left-r,bot-r),(right+r,top+r))++-- Simple transforms+getBox2 (Translate2 v symbObj) =+	let+		(a,b) = getBox2 symbObj+	in+		if (a,b) == ((0,0),(0,0))+		then ((0,0),(0,0))+		else (a+v, b+v)++getBox2 (Scale2 s symbObj) =+	let+		(a,b) = getBox2 symbObj+	in+		(s ⋯* a, s ⋯* b)++getBox2 (Rotate2 θ symbObj) = +	let+		((x1,y1),(x2,y2)) = getBox2 symbObj+		rotate (x,y) = ( cos(θ)*x - sin(θ)*y, sin(θ)*x + cos(θ)*y)+		(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))++-- Boundary mods+getBox2 (Shell2 w symbObj) = +	let+		(a,b) = getBox2 symbObj+		d = w/(2.0::ℝ)+	in+		(a - (d,d), b + (d,d))++getBox2 (Outset2 d symbObj) =+	let+		(a,b) = getBox2 symbObj+	in+		(a - (d,d), b + (d,d))++-- Misc+getBox2 (EmbedBoxedObj2 (obj,box)) = box
+ Graphics/Implicit/ObjectUtil/GetBox3.hs view
@@ -0,0 +1,144 @@+-- 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.ObjectUtil.GetBox3 (getBox3) where++import Prelude hiding ((+),(-),(*),(/))+import Graphics.Implicit.SaneOperators+import Graphics.Implicit.Definitions+import qualified Graphics.Implicit.MathUtil as MathUtil+import Data.Maybe (fromMaybe)++import  Graphics.Implicit.ObjectUtil.GetBox2 (getBox2)++getBox3 :: SymbolicObj3 -> Box3++-- Primitives+getBox3 (Rect3R r a b) = (a,b)++getBox3 (Sphere r ) = ((-r, -r, -r), (r,r,r))++getBox3 (Cylinder h r1 r2) = ( (-r,-r,0), (r,r,h) ) where r = max r1 r2++-- (Rounded) CSG+getBox3 (Complement3 symbObj) = +	((-infty, -infty, -infty), (infty, infty, infty)) where infty = (1::ℝ)/(0 ::ℝ)++getBox3 (UnionR3 r symbObjs) = ((left-r,bot-r,inward-r), (right+r,top+r,out+r))+	where +		boxes = map getBox3 symbObjs+		isEmpty = ( == ((0,0,0),(0,0,0)) )+		(leftbot, topright) = unzip $ filter (not.isEmpty) boxes+		(lefts, bots, ins) = unzip3 leftbot+		(rights, tops, outs) = unzip3 topright+		left = minimum lefts+		bot = minimum bots+		inward = minimum ins+		right = maximum rights+		top = maximum tops+		out = maximum outs++getBox3 (IntersectR3 r symbObjs) = +	let +		boxes = map getBox3 symbObjs+		(leftbot, topright) = unzip boxes+		(lefts, bots, ins) = unzip3 leftbot+		(rights, tops, outs) = unzip3 topright+		left = maximum lefts+		bot = maximum bots+		inward = maximum ins+		right = minimum rights+		top = minimum tops+		out = minimum outs+	in+		if   top   > bot +		  && right > left +		  && out   > inward+		then ((left,bot,inward),(right,top,out))+		else ((0,0,0),(0,0,0))++getBox3 (DifferenceR3 r symbObjs) = firstBox+	where+		firstBox:_ = map getBox3 symbObjs++-- Simple transforms+getBox3 (Translate3 v symbObj) =+	let+		(a,b) = getBox3 symbObj+	in+		(a+v, b+v)++getBox3 (Scale3 s symbObj) =+	let+		(a,b) = getBox3 symbObj+	in+		(s ⋯* a, s ⋯* b)++getBox3 (Rotate3 _ symbObj) = ( (-d, -d, -d), (d, d, d) )+	where+		((x1,y1, z1), (x2,y2, z2)) = getBox3 symbObj+		d = (sqrt (2::ℝ) *) $ maximum $ map abs [x1, x2, y1, y2, z1, z2]++-- Boundary mods+getBox3 (Shell3 w symbObj) = +	let+		(a,b) = getBox3 symbObj+		d = w/(2.0::ℝ)+	in+		(a - (d,d,d), b + (d,d,d))++getBox3 (Outset3 d symbObj) =+	let+		(a,b) = getBox3 symbObj+	in+		(a - (d,d,d), b + (d,d,d))++-- Misc+getBox3 (EmbedBoxedObj3 (obj,box)) = box++-- 2D Based+getBox3 (ExtrudeR r symbObj h) = ((x1,y1,0),(x2,y2,h))+	where+		((x1,y1),(x2,y2)) = getBox2 symbObj++getBox3 (ExtrudeOnEdgeOf symbObj1 symbObj2) =+	let+		((ax1,ay1),(ax2,ay2)) = getBox2 symbObj1+		((bx1,by1),(bx2,by2)) = getBox2 symbObj2+	in+		((bx1+ax1, by1+ax1, ay2), (bx2+ax2, by2+ax2, ay2))+++getBox3 (ExtrudeRM r twist scale translate symbObj (Left h)) = +	let+		((x1,y1),(x2,y2)) = getBox2 symbObj+		dx = x2 - x1+		dy = y2 - y1+		svals =  map (fromMaybe (const 1) scale) $ [0,h/(2::ℝ),h]+		sval = maximum $ map abs $ svals+		d = sval * sqrt (dx^2 + dy^2)+		(tvalsx, tvalsy) = unzip $ map (fromMaybe (const (0,0)) translate) $ [0,h/(2::ℝ),h]+		(tminx, tminy) = (minimum tvalsx, minimum tvalsy)+		(tmaxx, tmaxy) = (maximum tvalsx, maximum tvalsy)+	in+		((-d+tminx, -d+tminy, 0),(d+tmaxx, d+tmaxy, h)) ++getBox3 (ExtrudeRM r twist scale translate symbObj (Right hf)) = +	let+		((x1,y1),(x2,y2)) = getBox2 symbObj+		dx = x2 - x1+		dy = y2 - y1+		h = maximum [hf (x1,y1), hf (x2,y1), hf (x2,y2), hf (x1,y2), hf ((x1+x2)/(2::ℝ), (y1+y2)/(2::ℝ))]+		svals =  map (fromMaybe (const 1) scale) $ [0,h/(2::ℝ),h]+		sval = maximum $ map abs $ svals+		d = sval * sqrt (dx^2 + dy^2)+		(tvalsx, tvalsy) = unzip $ map (fromMaybe (const (0,0)) translate) $ [0,h/(2::ℝ),h]+		(tminx, tminy) = (minimum tvalsx, minimum tvalsy)+		(tmaxx, tmaxy) = (maximum tvalsx, maximum tvalsy)+	in+		((-d+tminx, -d+tminy, 0),(d+tmaxx, d+tmaxy, h))+++
+ Graphics/Implicit/ObjectUtil/GetImplicit2.hs view
@@ -0,0 +1,107 @@+-- 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.ObjectUtil.GetImplicit2 (getImplicit2) where++import Prelude hiding ((+),(-),(*),(/))+import qualified Prelude as P+import Graphics.Implicit.SaneOperators+import Graphics.Implicit.Definitions+import qualified Graphics.Implicit.MathUtil as MathUtil+import Data.List (nub)++getImplicit2 :: SymbolicObj2 -> Obj2++-- Primitives+getImplicit2 (RectR r (x1,y1) (x2,y2)) = \(x,y) -> MathUtil.rmaximum r+	[abs (x-dx/(2::ℝ)-x1) - dx/(2::ℝ), abs (y-dy/(2::ℝ)-y1) - dy/(2::ℝ)]+		where (dx, dy) = (x2-x1, y2-y1)++getImplicit2 (Circle r ) = +	\(x,y) -> sqrt (x**2 + y**2) - r++getImplicit2 (PolygonR r points) = +	\p -> let+		pair :: Int -> (ℝ2,ℝ2)+		pair n = (points !! n, points !! (mod (n + (1::Int) ) (length points) ) )+		pairs =  [ pair n | n <- [0 .. (length points) - (1 :: Int)] ]+		relativePairs =  map (\(a,b) -> (a - p, b - p) ) pairs+		crossing_points =+			[x2 - y2*(x2-x1)/(y2-y1) | ((x1,y1), (x2,y2)) <-relativePairs,+			   ( (y2 <= 0) && (y1 >= 0) ) || ( (y2 >= 0) && (y1 <= 0) ) ]+		seemsInRight = odd $ length $ filter (>0) $ nub crossing_points+		seemsInLeft = odd $ length $ filter (<0) $ nub crossing_points+		isIn = seemsInRight && seemsInLeft+		dists = map (MathUtil.distFromLineSeg p) pairs :: [ℝ]+	in+		minimum dists * if isIn then - (1 :: ℝ) else (1 :: ℝ)++-- (Rounded) CSG+getImplicit2 (Complement2 symbObj) = +	let+		obj = getImplicit2 symbObj+	in+		\p -> - obj p++getImplicit2 (UnionR2 r symbObjs) =+	let +		objs = map getImplicit2 symbObjs+	in+		if r == 0+		then \p -> minimum $ map ($p) objs +		else \p -> MathUtil.rminimum r $ map ($p) objs++getImplicit2 (DifferenceR2 r symbObjs) =+	let +		obj:objs = map getImplicit2 symbObjs+		complement obj = \p -> - obj p+	in+		if r == 0+		then \p -> maximum $ map ($p) $ obj:(map complement objs) +		else \p -> MathUtil.rmaximum r $ map ($p) $ obj:(map complement objs) ++getImplicit2 (IntersectR2 r symbObjs) = +	let +		objs = map getImplicit2 symbObjs+	in+		if r == 0+		then \p -> maximum $ map ($p) objs +		else \p -> MathUtil.rmaximum r $ map ($p) objs++-- Simple transforms+getImplicit2 (Translate2 v symbObj) =+	let+		obj = getImplicit2 symbObj+	in+		\p -> obj (p-v)++getImplicit2 (Scale2 s@(sx,sy) symbObj) =+	let+		obj = getImplicit2 symbObj+	in+		\p -> (max sx sy) * obj (p ⋯/ s)++getImplicit2 (Rotate2 θ symbObj) = +	let+		obj = getImplicit2 symbObj+	in+		\(x,y) -> obj ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x)++-- Boundary mods+getImplicit2 (Shell2 w symbObj) = +	let+		obj = getImplicit2 symbObj+	in+		\p -> abs (obj p) - w/(2.0::ℝ)++getImplicit2 (Outset2 d symbObj) =+	let+		obj = getImplicit2 symbObj+	in+		\p -> obj p - d++-- Misc+getImplicit2 (EmbedBoxedObj2 (obj,box)) = obj+
+ Graphics/Implicit/ObjectUtil/GetImplicit3.hs view
@@ -0,0 +1,139 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ViewPatterns #-}++module Graphics.Implicit.ObjectUtil.GetImplicit3 (getImplicit3) where++import Prelude hiding ((+),(-),(*),(/))+import Graphics.Implicit.SaneOperators+import Graphics.Implicit.Definitions+import qualified Graphics.Implicit.MathUtil as MathUtil+import qualified Data.Maybe as Maybe++import  Graphics.Implicit.ObjectUtil.GetImplicit2 (getImplicit2)++getImplicit3 :: SymbolicObj3 -> Obj3++-- Primitives+getImplicit3 (Rect3R r (x1,y1,z1) (x2,y2,z2)) = \(x,y,z) -> MathUtil.rmaximum r+	[abs (x-dx/(2::ℝ)-x1) - dx/(2::ℝ), abs (y-dy/(2::ℝ)-y1) - dy/(2::ℝ), abs (z-dz/(2::ℝ)-z1) - dz/(2::ℝ)]+		where (dx, dy, dz) = (x2-x1, y2-y1, z2-z1)++getImplicit3 (Sphere r ) = +	\(x,y,z) -> sqrt (x**2 + y**2 + z**2) - r++getImplicit3 (Cylinder h r1 r2) = \(x,y,z) ->+	let+		d = sqrt(x^2+y^2) - ((r2-r1)/h*z+r1)+		θ = atan2 (r2-r1) h+	in+		max (d * cos θ) (abs(z-h/(2::ℝ)) - h/(2::ℝ))++-- (Rounded) CSG+getImplicit3 (Complement3 symbObj) = +	let+		obj = getImplicit3 symbObj+	in+		\p -> - obj p++getImplicit3 (UnionR3 r symbObjs) =+	let +		objs = map getImplicit3 symbObjs+	in+		if r == 0+		then \p -> minimum $ map ($p) objs +		else \p -> MathUtil.rminimum r $ map ($p) objs++getImplicit3 (IntersectR3 r symbObjs) = +	let +		objs = map getImplicit3 symbObjs+	in+		if r == 0+		then \p -> maximum $ map ($p) objs +		else \p -> MathUtil.rmaximum r $ map ($p) objs++getImplicit3 (DifferenceR3 r symbObjs) =+	let +		obj:objs = map getImplicit3 symbObjs+		complement obj = \p -> - obj p+	in+		if r == 0+		then \p -> maximum $ map ($p) $ obj:(map complement objs) +		else \p -> MathUtil.rmaximum r $ map ($p) $ obj:(map complement objs) ++-- Simple transforms+getImplicit3 (Translate3 v symbObj) =+	let+		obj = getImplicit3 symbObj+	in+		\p -> obj (p-v)++getImplicit3 (Scale3 s@(sx,sy,sz) symbObj) =+	let+		obj = getImplicit3 symbObj+	in+		\p -> (maximum [sx, sy, sz]) * obj (p ⋯/ s)++getImplicit3 (Rotate3 (yz, xz, xy) symbObj) = +	let+		obj = getImplicit3 symbObj+		rotateYZ :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)+		rotateYZ θ obj = \(x,y,z) -> obj ( x, cos(θ)*z - sin(θ)*y, cos(θ)*y + sin(θ)*z)+		rotateXZ :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)+		rotateXZ θ obj = \(x,y,z) -> obj ( cos(θ)*x + sin(θ)*z, y, cos(θ)*z - sin(θ)*x)+		rotateXY :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)+		rotateXY θ obj = \(x,y,z) -> obj ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x, z)+	in+		rotateYZ yz $ rotateXZ xz $ rotateXY xy $ obj++-- Boundary mods+getImplicit3 (Shell3 w symbObj) = +	let+		obj = getImplicit3 symbObj+	in+		\p -> abs (obj p) - w/(2::ℝ)++getImplicit3 (Outset3 d symbObj) =+	let+		obj = getImplicit3 symbObj+	in+		\p -> obj p - d++-- Misc+getImplicit3 (EmbedBoxedObj3 (obj,box)) = obj++-- 2D Based+getImplicit3 (ExtrudeR r symbObj h) = +	let+		obj = getImplicit2 symbObj+	in+		\(x,y,z) -> MathUtil.rmax r (obj (x,y)) (abs (z - h/(2::ℝ)) - h/(2::ℝ))++getImplicit3 (ExtrudeRM r twist scale translate symbObj height) = +	let+		obj = getImplicit2 symbObj+		twist' = Maybe.fromMaybe (const 0) twist+		scale' = Maybe.fromMaybe (const 1) scale+		translate' = Maybe.fromMaybe (const (0,0)) translate+		height' (x,y) = case height of+			Left n -> n+			Right f -> f (x,y)+		scaleVec :: ℝ -> ℝ2 -> ℝ2+		scaleVec  s = \(x,y) -> (x/s, y/s)+		rotateVec :: ℝ -> ℝ2 -> ℝ2+		rotateVec θ (x,y) = (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ)) +		k = (pi :: ℝ)/(180:: ℝ)+	in+		\(x,y,z) -> let h = height' (x,y) in+			MathUtil.rmax r +				(obj . rotateVec (-k*twist' z) . scaleVec (scale' z) . (\a -> a- translate' z) $ (x,y))+				(abs (z - h/(2::ℝ)) - h/(2::ℝ))+++getImplicit3 (ExtrudeOnEdgeOf symbObj1 symbObj2) =+	let+		obj1 = getImplicit2 symbObj1+		obj2 = getImplicit2 symbObj2+	in+		\(x,y,z) -> obj1 (obj2 (x,y), z)
− Graphics/Implicit/Operations.hs 
@@ -1,71 +0,0 @@--- 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 (-	BasicObj, MagnitudeObj,-	translate, -	scale,-	rotateXY,-	complement,-	union,  intersect,  difference, -	unionR,  intersectR,  differenceR, -	outset,-	shell,-	extrudeR, extrudeRMod,-	extrudeOnEdgeOf,-	rotate3-) where---- 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----{- 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 :: -	ℝ         -- ^ z-level to cut at-	-> Obj3   -- ^ 3D object to slice from-	-> Obj2   -- ^ Resulting 2D object-slice z obj = \(a,b) -> obj (a,b,z)----- | Extrude a 2D object. (The extrusion goes into the z-plane)-extrude :: -	ℝ          -- ^ Length to extrude-	-> Obj2    -- ^ 2D object to extrude-	-> Obj3    -- ^ Resulting 3D object-extrude h obj = \(x,y,z) -> max (obj (x,y)) (abs (z + h/(2.0 :: ℝ )) - h)---- | Rounded extrude. Instead of the extrude having a flat top or bottom, it is bevelled.-extrudeR ::-	ℝ          -- ^ Radius of rounding-	-> ℝ       -- ^ Length to extrude-	-> Obj2    -- ^ 2D object to extrude-	-> Obj3    -- ^ Resulting 3D object-extrudeR r h obj = \(x,y,z) -> rmax r (obj (x,y)) (abs (z + h/(2.0 :: ℝ)) - h)---- | Create a 3D object by extruding a 2D object along the edge of another 2D object.--- For example, extruding a circle on the edge of another circle would make a torus.-extrudeOnEdgeOf :: -	Obj2     -- ^ Object to extrude-	-> Obj2  -- ^ Object to extrude along the edge of-	-> Obj3  -- ^ Resulting 3D object-extrudeOnEdgeOf a b = \(x,y,z) -> a (b (x,y), z) ----}
− Graphics/Implicit/Operations/Box2.hs 
@@ -1,68 +0,0 @@---- 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 
@@ -1,65 +0,0 @@--- 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 
@@ -1,30 +0,0 @@--- 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 
@@ -1,38 +0,0 @@--- 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 
@@ -1,36 +0,0 @@--- 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 
@@ -1,22 +0,0 @@--- 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 
@@ -1,141 +0,0 @@--- 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 
@@ -1,29 +0,0 @@--- 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 
@@ -1,29 +0,0 @@--- 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 
@@ -1,34 +0,0 @@--- 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 
@@ -1,29 +0,0 @@--- 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 
@@ -1,29 +0,0 @@--- 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 
@@ -1,21 +0,0 @@--- 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,81 +1,196 @@ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU GPL, see LICENSE -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, NoMonomorphismRestriction #-} -module Graphics.Implicit.Primitives (-	sphere,-	circle,-	cylinder, cylinderC, cylinder2, cylinder2C,-	rect3R, rectR,-	regularPolygon,-	polygonR,-	zsurface-) where+module Graphics.Implicit.Primitives where --- Some type definitions :) import Graphics.Implicit.Definitions+import Data.List (sortBy)+import Graphics.Implicit.MathUtil   (pack)+import Graphics.Implicit.ObjectUtil (getBox2, getBox3, getImplicit2, getImplicit3) --- Most of the functions we're exporting come from here--- They are methods of classes.-import Graphics.Implicit.Primitives.Definitions+-- $ 3D Primitives --- 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+sphere ::+	ℝ                  -- ^ Radius of the sphere+	-> SymbolicObj3    -- ^ Resulting sphere --- We export a few functions modified by operations--- for users conveniences...-import Graphics.Implicit.Operations+sphere r = Sphere r --- 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/+rect3R ::+	ℝ                 -- ^ Rounding of corners+	-> ℝ3             -- ^ Bottom.. corner+	-> ℝ3             -- ^ Top right... corner+	-> SymbolicObj3   -- ^ Resuting cube - (0,0,0) is bottom left... -cylinder :: (PrimitiveSupporter3 obj, BasicObj obj ℝ3) =>-	ℝ         -- ^ Radius of the cylinder	-	-> ℝ      -- ^ Height of the cylinder-	-> obj    -- ^ Resulting cylinder-cylinder r h = cylinder2 r r h+rect3R = Rect3R -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+cylinder2 ::+	ℝ                   -- ^ Radius of the cylinder	+	-> ℝ                -- ^ Second radius of the cylinder+	-> ℝ                -- ^ Height of the cylinder+	-> SymbolicObj3     -- ^ Resulting cylinder +cylinder2 r1 r2 h = Cylinder h r1 r2 -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+cylinder r = cylinder2 r r +-- $ 2D Primitives +circle ::+	ℝ               -- ^ radius of the circle+	-> SymbolicObj2 -- ^ resulting circle -regularPolygon ::-	ℕ       -- ^ number of sides-	-> ℝ    -- ^ radius-	-> Obj2 -- ^ resulting regular polygon-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+circle   = Circle +rectR ::+	ℝ+	-> ℝ2           -- ^ Bottom left corner+	-> ℝ2           -- ^ Top right corner+	-> SymbolicObj2 -- ^ Resulting square (bottom right = (0,0) ) -zsurface ::-	(ℝ2 -> ℝ) -- ^ Description of the height of the surface-	-> Obj3   -- ^ Resulting 3D object-zsurface f = \(x,y,z) -> f (x,y) - z+rectR = RectR +polygonR ::+	ℝ                -- ^ Rouding of the polygon+	-> [ℝ2]          -- ^ Verticies of the polygon+	-> SymbolicObj2  -- ^ Resulting polygon --- 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+polygonR = PolygonR++polygon = polygonR 0++-- $ Shared Operations++class Object obj vec | obj -> vec where+	+	-- | Translate an object by a vector of appropriate dimension. +	translate :: +		vec      -- ^ Vector to translate by (Also: a is a vector, blah, blah)+		-> obj   -- ^ Object to translate+		-> obj   -- ^ Resulting object++	-- | Scale an object+	scale :: +		vec     -- ^ Amount to scale by+		-> obj  -- ^ Object to scale+		-> obj  -- ^ Resulting scaled object	+	+	-- | Complement an Object+	complement :: +		obj     -- ^ Object to complement+		-> obj  -- ^ Result+	+	-- | Rounded union+	unionR :: +		ℝ        -- ^ The radius of rounding+		-> [obj] -- ^ objects to union+		-> obj   -- ^ Resulting object+	+	-- | Rounded minimum+	intersectR :: +		ℝ        -- ^ The radius of rounding+		-> [obj] -- ^ Objects to intersect+		-> obj   -- ^ Resulting object+	+	-- | Rounded difference+	differenceR :: +		ℝ        -- ^ The radius of rounding+		-> [obj] -- ^ Objects to difference +		-> obj   -- ^ Resulting object++	-- | Outset an object.+	outset :: +		ℝ        -- ^ distance to outset+		-> obj   -- ^ object to outset+		-> obj   -- ^ resulting object++	-- | Make a shell of an object.+	shell :: +		ℝ        -- ^ width of shell+		-> obj   -- ^ object to take shell of+		-> obj   -- ^ resulting shell++	-- | Get the bounding box an object+	getBox :: +		obj           -- ^ Object to get box of+		-> (vec, vec) -- ^ Bounding box++	-- | Get the implicit function for an object+	getImplicit :: +		obj           -- ^ Object to get implicit function of+		-> (vec -> ℝ) -- ^ Implicit function++	implicit :: +		(vec -> ℝ)     -- ^ Implicit function+		-> (vec, vec)  -- ^ Bounding box+		-> obj         -- ^ Resulting object+	++instance Object SymbolicObj2 ℝ2 where+	translate   = Translate2+	scale       = Scale2+	complement  = Complement2+	unionR      = UnionR2+	intersectR  = IntersectR2+	differenceR = DifferenceR2+	outset      = Outset2+	shell       = Shell2+	getBox      = getBox2+	getImplicit = getImplicit2+	implicit a b= EmbedBoxedObj2 (a,b)++instance Object SymbolicObj3 ℝ3 where+	translate   = Translate3+	scale       = Scale3+	complement  = Complement3+	unionR      = UnionR3+	intersectR  = IntersectR3+	differenceR = DifferenceR3+	outset      = Outset3+	shell       = Shell3+	getBox      = getBox3+	getImplicit = getImplicit3+	implicit a b= EmbedBoxedObj3 (a,b)++union = unionR 0+difference = differenceR 0+intersect = intersectR 0++-- 3D operations++extrudeR = ExtrudeR++extrudeRM = ExtrudeRM++extrudeOnEdgeOf = ExtrudeOnEdgeOf++rotate3 = Rotate3+++pack3 :: ℝ2 -> ℝ -> [SymbolicObj3] -> Maybe SymbolicObj3+pack3 (dx, dy) sep objs = +	let+		boxDropZ ((a,b,c),(d,e,f)) = ((a,b),(d,e))+		withBoxes :: [(Box2, SymbolicObj3)]+		withBoxes = map (\obj -> ( boxDropZ $ getBox3 obj, obj)) objs+	in case pack ((0,0),(dy,dy)) sep withBoxes of+			(a, []) -> Just $ union $ map (\((x,y),obj) -> translate (x,y,0) obj) a+			_ -> Nothing+				++-- 2D operations++rotate = Rotate2+++pack2 :: ℝ2 -> ℝ -> [SymbolicObj2] -> Maybe SymbolicObj2+pack2 (dx, dy) sep objs = +	let+		withBoxes :: [(Box2, SymbolicObj2)]+		withBoxes = map (\obj -> ( getBox2 obj, obj)) objs+	in case pack ((0,0),(dy,dy)) sep withBoxes of+			(a, []) -> Just $ union $ map (\((x,y),obj) -> translate (x,y) obj) a+			_ -> Nothing+
− Graphics/Implicit/Primitives/BoxedObj2.hs 
@@ -1,20 +0,0 @@--- 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 
@@ -1,18 +0,0 @@--- 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 
@@ -1,46 +0,0 @@--- 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 
@@ -1,49 +0,0 @@--- 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 
@@ -1,21 +0,0 @@--- 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 
@@ -1,17 +0,0 @@--- 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 
@@ -1,18 +0,0 @@--- 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
@@ -36,6 +36,13 @@ class InnerProductSpace a where 	(⋅) :: a -> a -> ℝ +class ComponentWiseMultiplicative a b c | a b -> c where+	(⋯*) :: a -> b -> c+	infixl 7 ⋯*++class ComponentWiseMultiplicativeInvertable a where+	componentWiseMultiplicativeInverse :: a -> a+ -- * I should be able to create instances for all Num instances, -- but Haskell's type checker doesn't seem to play nice with them. @@ -163,4 +170,31 @@ 	(a1, a2, a3) ⋅ (b1, b2, b3) = a1*b1 + a2*b2+a3*b3  +-- ComponentWiseMultiplicative Instances +instance ComponentWiseMultiplicativeInvertable ℝ where+	componentWiseMultiplicativeInverse a = 1 P./ a++instance ComponentWiseMultiplicativeInvertable ℝ2 where+	componentWiseMultiplicativeInverse (a, b) = (1 P./ a, 1 P./ b)++instance ComponentWiseMultiplicativeInvertable ℝ3 where+	componentWiseMultiplicativeInverse (a, b, c) = (1 P./ a, 1 P./ b, 1 P./ c)++instance ComponentWiseMultiplicative ℝ ℝ ℝ where+	a ⋯* x = a*x++instance ComponentWiseMultiplicative ℝ2 ℝ2 ℝ2 where+	(a,b) ⋯* (x,y) = (a*x,b*y)++instance ComponentWiseMultiplicative ℝ3 ℝ3 ℝ3 where+	(a,b,c) ⋯* (x,y,z) = (a*x,b*y,c*z)++(⋯/) :: (ComponentWiseMultiplicative a b c) => (ComponentWiseMultiplicativeInvertable b) => a -> b -> c+x ⋯/ y = x ⋯* (componentWiseMultiplicativeInverse y)+infixl 7 ⋯/+++(a1,a2,a3) ⨯ (b1,b2,b3) = (a2*b3-a3*b2, a3*b1-a1*b3, a1*b2-a2*b1)++normalized v = v / norm v
extopenscad.hs view
@@ -1,14 +1,21 @@ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU GPL, see LICENSE +{-# LANGUAGE ViewPatterns #-}+ -- 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.Environment (getArgs) import System.IO (openFile, IOMode (ReadMode), hGetContents, hClose)-import Graphics.Implicit (runOpenscad, writeSVG, writeSTL)+import Graphics.Implicit (runOpenscad, writeSVG, writeSTL, writeOBJ, writeSCAD3, writeSCAD2, writeGCodeHacklabLaser, writeTHREEJS) import Graphics.Implicit.ExtOpenScad.Definitions (OpenscadObj (ONum))+import Graphics.Implicit.ObjectUtil (getBox2, getBox3)+import Graphics.Implicit.Definitions (xmlErrorOn, errorMessage) import Data.Map as Map+import Text.ParserCombinators.Parsec (errorPos, sourceLine)+import Text.ParserCombinators.Parsec.Error+import Data.IORef (writeIORef)  -- | strip a .scad or .escad file to its basename. strip :: String -> String@@ -17,36 +24,114 @@ 	'd':'a':'c':'s':'e':'.':xs -> reverse xs 	_                          -> filename +-- | Get the file type ending of a file+--  eg. "foo.stl" -> "stl"+fileType filename = reverse $ beforeFirstPeriod $ reverse filename+	where+		beforeFirstPeriod []       = [] +		beforeFirstPeriod ('.':xs) = []+		beforeFirstPeriod (  x:xs) = x : beforeFirstPeriod xs++getRes (Map.lookup "$res" -> Just (ONum res), _, _) = res++getRes (_, _, obj:_) = min (minimum [x,y,z]/2) ((x*y*z)**(1/3) / 22)+	where+		((x1,y1,z1),(x2,y2,z2)) = getBox3 obj+		(x,y,z) = (x2-x1, y2-y1, z2-z1)++getRes (_, obj:_, _) = min (min x y/2) ((x*y)**0.5 / 30)+	where+		((x1,y1),(x2,y2)) = getBox2 obj+		(x,y) = (x2-x1, y2-y1)++getRes _ = 1+ -- | 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+	Left err -> +		let+			line = sourceLine . errorPos $ err+			msgs = errorMessages err+		in errorMessage line $ showErrorMessages +			"or" "unknown parse error" "expecting" "unexpected" "end of input"+            (errorMessages 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 +		let+			res = getRes s+		case s of  			(_, [], [])   -> putStrLn "Nothing to render" 			(_, x:xs, []) -> do 				putStrLn $ "Rendering 2D object to " ++ targetname ++ ".svg"+				putStrLn $ show x 				writeSVG res (targetname ++ ".svg") x 			(_, _, x:xs)  -> do 				putStrLn $ "Rendering 3D object to " ++ targetname++ ".stl"+				putStrLn $ show x 				writeSTL res (targetname ++ ".stl") x++-- | Give an openscad object to run and the basename of +--   the target to write to... write an object!+executeAndExportSpecifiedTargetType :: String -> String -> String -> IO ()+executeAndExportSpecifiedTargetType content targetname formatname = case runOpenscad content of+	Left err -> putStrLn $ show $ err+	Right openscadProgram -> do +		s@(vars, obj2s, obj3s) <- openscadProgram +		let+			res = getRes s+		case (formatname, s) of +			(_, (_, [], []))   -> putStrLn "Nothing to render"+			("svg", (_, x:xs, _)) -> do+				putStrLn $ "Rendering 2D object to " ++ targetname+				writeSVG res targetname x+			("ngc", (_, x:xs, _)) -> do+				putStrLn $ "Rendering 2D object to " ++ targetname+				writeGCodeHacklabLaser res targetname x+			("scad", (_, x:xs, _))  -> do+				putStrLn $ "Rendering 3D object to " ++ targetname+				writeSCAD2 res targetname x+			("stl", (_, _, x:xs))  -> do+				putStrLn $ "Rendering 3D object to " ++ targetname+				writeSTL res targetname x+			("scad", (_, _, x:xs))  -> do+				putStrLn $ "Rendering 3D object to " ++ targetname+				writeSCAD3 res targetname x+			("obj", (_, _, x:xs))  -> do+				putStrLn $ "Rendering 3D object to " ++ targetname+				writeOBJ res targetname x+			("js", (_, _, x:xs))  -> do+				putStrLn $ "Rendering 3D object to " ++ targetname+				writeTHREEJS res targetname x+			(otherFormat, _) -> putStrLn $ "Unrecognized format: " ++ otherFormat+ 		  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+	if Prelude.null args || args == ["--help"] || args == ["-help"]+		then putStrLn $ +			"syntax: extopenscad inputfile.escad [outputfile.format]\n"+			++ "eg. extopenscad input.escad out.stl"+		else do+			let+				args' = if head args == "-xml-error" then tail args else args+			writeIORef xmlErrorOn (head args == "-xml-error")+			case length args' of+				0 -> putStrLn $ +					"syntax: extopenscad inputfile.escad [outputfile.format]\n"+					++ "eg. extopenscad input.escad out.stl"+				1 -> do+					f <- openFile (args' !! 0) ReadMode+					content <- hGetContents f +					executeAndExport content (strip $ args' !! 0)+					hClose f+				2 -> do+					f <- openFile (args' !! 0) ReadMode+					content <- hGetContents f +					executeAndExportSpecifiedTargetType +						content (args' !! 1) (fileType $ args' !! 1)+					hClose f
implicit.cabal view
@@ -1,5 +1,5 @@ Name:                implicit-Version:             0.0.1+Version:             0.0.2 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,65 +15,96 @@ Category:            Graphics  Library-    Build-Depends:       base >= 3 && < 5, parsec, hashmap, parallel, containers, haskell98-    ghc-options:         -O2-    Extensions:          MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances++    Build-Depends:+        base >= 3 && < 5,+        parsec,+        hashmap,+        parallel,+        containers,+        plugins,+        deepseq++    ghc-options:+        -O2 -optc-O3+        -threaded+        -rtsopts+        -funfolding-use-threshold=16 +        -fspec-constr-count=10++    Extensions:+        FlexibleContexts,+        FlexibleInstances,+        FunctionalDependencies,+        GADTs,+        IncoherentInstances,+        KindSignatures,+        MultiParamTypeClasses,+        NoMonomorphismRestriction,+        OverloadedStrings,+        ParallelListComp,+        RankNTypes,+        ScopedTypeVariables,+        TypeSynonymInstances,+        UndecidableInstances,+        ViewPatterns+     Exposed-Modules:            Graphics.Implicit         Graphics.Implicit.Definitions         Graphics.Implicit.Export         Graphics.Implicit.MathUtil-        Graphics.Implicit.Operations         Graphics.Implicit.SaneOperators+        Graphics.Implicit.ExtOpenScad+        Graphics.Implicit.ObjectUtil+     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.ObjectUtil.GetBox2+        Graphics.Implicit.ObjectUtil.GetBox3+        Graphics.Implicit.ObjectUtil.GetImplicit2+        Graphics.Implicit.ObjectUtil.GetImplicit3         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.ExtOpenScad.Util.Computation+        Graphics.Implicit.ExtOpenScad.Util.ArgParser         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.NormedTriangleMeshFormats+        Graphics.Implicit.Export.SymbolicFormats         Graphics.Implicit.Export.Util-        Graphics.Implicit.Export.Symbolic.CoerceSymbolic2-        Graphics.Implicit.Export.Symbolic.CoerceSymbolic3         Graphics.Implicit.Export.Symbolic.Rebound2         Graphics.Implicit.Export.Symbolic.Rebound3+        Graphics.Implicit.Export.Render+        Graphics.Implicit.Export.Render.Definitions+        Graphics.Implicit.Export.Render.GetLoops+        Graphics.Implicit.Export.Render.GetSegs+        Graphics.Implicit.Export.Render.HandleSquares+        Graphics.Implicit.Export.Render.Interpolate+        Graphics.Implicit.Export.Render.RefineSegs+        Graphics.Implicit.Export.Render.TesselateLoops  Executable extopenscad     Main-is: extopenscad.hs+   ghc-options:+        -O2 -optc-O3+        -threaded+        -rtsopts+        -funfolding-use-threshold=16 +        -fspec-constr-count=10+ source-repository head     type:            git     location:        https://github.com/colah/ImplicitCAD.git+