implicit 0.0.2 → 0.0.3
raw patch · 49 files changed
+3288/−2196 lines, 49 filesdep +JuicyPixelsdep +blaze-builderdep +blaze-markupdep −hashmapdep −pluginsdep ~base
Dependencies added: JuicyPixels, blaze-builder, blaze-markup, blaze-svg, bytestring, directory, filepath, mtl, optparse-applicative, storable-endian, text, unordered-containers, vector-space
Dependencies removed: hashmap, plugins
Dependency ranges changed: base
Files
- Graphics/Implicit.hs +22/−2
- Graphics/Implicit/Definitions.hs +31/−6
- Graphics/Implicit/Export.hs +40/−14
- Graphics/Implicit/Export/MarchingSquares.hs +23/−16
- Graphics/Implicit/Export/NormedTriangleMeshFormats.hs +16/−16
- Graphics/Implicit/Export/PolylineFormats.hs +69/−43
- Graphics/Implicit/Export/RayTrace.hs +216/−0
- Graphics/Implicit/Export/Render.hs +95/−56
- Graphics/Implicit/Export/Render/Definitions.hs +8/−0
- Graphics/Implicit/Export/Render/GetLoops.hs +41/−0
- Graphics/Implicit/Export/Render/GetSegs.hs +99/−18
- Graphics/Implicit/Export/Render/HandlePolylines.hs +108/−0
- Graphics/Implicit/Export/Render/HandleSquares.hs +94/−30
- Graphics/Implicit/Export/Render/Interpolate.hs +140/−25
- Graphics/Implicit/Export/Render/RefineSegs.hs +33/−23
- Graphics/Implicit/Export/Render/TesselateLoops.hs +41/−19
- Graphics/Implicit/Export/Symbolic/Rebound2.hs +3/−3
- Graphics/Implicit/Export/Symbolic/Rebound3.hs +3/−3
- Graphics/Implicit/Export/SymbolicFormats.hs +85/−69
- Graphics/Implicit/Export/SymbolicObj2.hs +13/−11
- Graphics/Implicit/Export/SymbolicObj3.hs +4/−7
- Graphics/Implicit/Export/TextBuilderUtils.hs +57/−0
- Graphics/Implicit/Export/TriangleMeshFormats.hs +81/−55
- Graphics/Implicit/Export/Util.hs +13/−10
- Graphics/Implicit/ExtOpenScad.hs +28/−11
- Graphics/Implicit/ExtOpenScad/Default.hs +158/−2
- Graphics/Implicit/ExtOpenScad/Definitions.hs +57/−125
- Graphics/Implicit/ExtOpenScad/Eval/Expr.hs +99/−0
- Graphics/Implicit/ExtOpenScad/Eval/Statement.hs +142/−0
- Graphics/Implicit/ExtOpenScad/Expressions.hs +0/−285
- Graphics/Implicit/ExtOpenScad/Parser/Expr.hs +244/−0
- Graphics/Implicit/ExtOpenScad/Parser/Statement.hs +276/−0
- Graphics/Implicit/ExtOpenScad/Parser/Util.hs +57/−0
- Graphics/Implicit/ExtOpenScad/Primitives.hs +228/−113
- Graphics/Implicit/ExtOpenScad/Statements.hs +0/−482
- Graphics/Implicit/ExtOpenScad/Util.hs +0/−176
- Graphics/Implicit/ExtOpenScad/Util/ArgParser.hs +50/−68
- Graphics/Implicit/ExtOpenScad/Util/Computation.hs +0/−79
- Graphics/Implicit/ExtOpenScad/Util/OVal.hs +137/−0
- Graphics/Implicit/ExtOpenScad/Util/StateC.hs +67/−0
- Graphics/Implicit/MathUtil.hs +9/−9
- Graphics/Implicit/ObjectUtil/GetBox2.hs +58/−39
- Graphics/Implicit/ObjectUtil/GetBox3.hs +68/−35
- Graphics/Implicit/ObjectUtil/GetImplicit2.hs +9/−11
- Graphics/Implicit/ObjectUtil/GetImplicit3.hs +69/−14
- Graphics/Implicit/Primitives.hs +4/−0
- Graphics/Implicit/SaneOperators.hs +0/−200
- extopenscad.hs +163/−108
- implicit.cabal +30/−13
Graphics/Implicit.hs view
@@ -30,17 +30,37 @@ -- Export writeSVG, writeSTL,+ writeBinSTL, writeOBJ, writeTHREEJS, writeSCAD2, writeSCAD3, writeGCodeHacklabLaser,- runOpenscad+ writePNG2,+ writePNG3,+ runOpenscad,+ implicit,+ SymbolicObj2,+ SymbolicObj3 ) where -- Let's be explicit about where things come from :) import Graphics.Implicit.Primitives import Graphics.Implicit.ExtOpenScad (runOpenscad)-import Graphics.Implicit.Export+import qualified Graphics.Implicit.Export as Export+import Graphics.Implicit.Definitions +-- We want Export to be a bit less polymorphic+-- (so that types will collapse nicely)++writeSVG = Export.writeSVG :: ℝ -> FilePath -> SymbolicObj2 -> IO ()+writeSTL = Export.writeSTL :: ℝ -> FilePath -> SymbolicObj3 -> IO ()+writeBinSTL = Export.writeBinSTL :: ℝ -> FilePath -> SymbolicObj3 -> IO ()+writeOBJ = Export.writeOBJ :: ℝ -> FilePath -> SymbolicObj3 -> IO ()+writeSCAD2 = Export.writeSCAD2 :: ℝ -> FilePath -> SymbolicObj2 -> IO ()+writeSCAD3 = Export.writeSCAD3 :: ℝ -> FilePath -> SymbolicObj3 -> IO ()+writeTHREEJS = Export.writeTHREEJS :: ℝ -> FilePath -> SymbolicObj3 -> IO ()+writeGCodeHacklabLaser = Export.writeGCodeHacklabLaser :: ℝ -> FilePath -> SymbolicObj2 -> IO () +writePNG2 = Export.writePNG :: ℝ -> FilePath -> SymbolicObj2 -> IO ()+writePNG3 = Export.writePNG :: ℝ -> FilePath -> SymbolicObj3 -> IO ()
Graphics/Implicit/Definitions.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, OverlappingInstances #-}+ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU GPL, see LICENSE @@ -7,6 +9,8 @@ -- we want global IO refs. import Data.IORef (IORef, newIORef, readIORef) import System.IO.Unsafe (unsafePerformIO)+import Data.VectorSpace +import Control.Applicative -- Let's make things a bit nicer. -- Following math notation ℝ, ℝ², ℝ³...@@ -16,6 +20,21 @@ type ℕ = Int +-- TODO: Find a better place for this+(⋅) :: InnerSpace a => a -> a -> Scalar a+(⋅) = (<.>)++-- TODO: Find a better way to do this?+class ComponentWiseMultable a where+ (⋯*) :: a -> a -> a+ (⋯/) :: a -> a -> a+instance ComponentWiseMultable ℝ2 where+ (x,y) ⋯* (x',y') = (x*x', y*y')+ (x,y) ⋯/ (x',y') = (x/x', y/y')+instance ComponentWiseMultable ℝ3 where+ (x,y,z) ⋯* (x',y',z') = (x*x', y*y', z*z')+ (x,y,z) ⋯/ (x',y',z') = (x/x', y/y', z/z')+ -- nxn matrices -- eg. M2 ℝ = M₂(ℝ) type M2 a = ((a,a),(a,a))@@ -108,6 +127,7 @@ | Translate3 ℝ3 SymbolicObj3 | Scale3 ℝ3 SymbolicObj3 | Rotate3 (ℝ,ℝ,ℝ) SymbolicObj3+ | Rotate3V ℝ ℝ3 SymbolicObj3 -- Boundary mods | Outset3 ℝ SymbolicObj3 | Shell3 ℝ SymbolicObj3@@ -117,12 +137,17 @@ | ExtrudeR ℝ SymbolicObj2 ℝ | ExtrudeRotateR ℝ ℝ SymbolicObj2 ℝ | ExtrudeRM - ℝ -- ^ rounding radius- (Maybe (ℝ -> ℝ)) -- ^ twist- (Maybe (ℝ -> ℝ)) -- ^ scale- (Maybe (ℝ -> ℝ2)) -- ^ translate- SymbolicObj2 -- ^ object to extrude- (Either ℝ (ℝ2 -> ℝ)) -- ^ height to extrude to+ ℝ -- rounding radius+ (Maybe (ℝ -> ℝ)) -- twist+ (Maybe (ℝ -> ℝ)) -- scale+ (Maybe (ℝ -> ℝ2)) -- ranslate+ SymbolicObj2 -- object to extrude+ (Either ℝ (ℝ2 -> ℝ)) -- height to extrude to+ | RotateExtrude+ ℝ -- Angle to sweep to+ (Maybe ℝ) -- Loop or path (rounded corner)+ (Either ℝ2 (ℝ -> ℝ2)) -- translate function+ SymbolicObj2 -- object to extrude | ExtrudeOnEdgeOf SymbolicObj2 SymbolicObj2 deriving Show
Graphics/Implicit/Export.hs view
@@ -6,14 +6,18 @@ import Graphics.Implicit.Definitions --import Graphics.Implicit.Operations (slice) -import System.IO (writeFile)+import Data.Text.Lazy (Text,pack)+import Data.Text.Lazy.IO (writeFile)+import Prelude hiding (writeFile)+import qualified Data.ByteString.Lazy as LBS -- class DiscreteApproxable import Graphics.Implicit.Export.Definitions -- instances of DiscreteApproxable...-import Graphics.Implicit.Export.SymbolicObj2-import Graphics.Implicit.Export.SymbolicObj3+import Graphics.Implicit.Export.SymbolicObj2 ()+import Graphics.Implicit.Export.SymbolicObj3 ()+import Graphics.Implicit.Export.RayTrace () -- File formats import qualified Graphics.Implicit.Export.PolylineFormats as PolylineFormats@@ -21,33 +25,55 @@ import qualified Graphics.Implicit.Export.NormedTriangleMeshFormats as NormedTriangleMeshFormats import qualified Graphics.Implicit.Export.SymbolicFormats as SymbolicFormats +import qualified Codec.Picture as ImageFormatCodecs+ -- Write an object in a given formet... writeObject :: (DiscreteAproxable obj aprox) => - ℝ -- ^ Resolution- -> (aprox -> String) -- ^ File Format (Function that formats)- -> FilePath -- ^ File Name- -> obj -- ^ Object to render- -> IO() -- ^ Writing Action!+ ℝ -- ^ Resolution+ -> (aprox -> Text) -- ^ File Format (Function that formats)+ -> FilePath -- ^ File Name+ -> obj -- ^ Object to render+ -> IO () -- ^ Writing Action! -writeObject res format filename obj = writeFile filename text - where+writeObject res format filename obj = writeFile filename $ formatObject res format obj++writeObject' :: (DiscreteAproxable obj aprox) => + ℝ -- ^ Resolution+ -> (FilePath -> aprox -> IO ()) -- ^ File Format writer+ -> FilePath -- ^ File Name+ -> obj -- ^ Object to render+ -> IO () -- ^ Writing Action!++writeObject' res formatWriter filename obj =+ let aprox = discreteAprox res obj- text = format aprox+ in + formatWriter filename aprox --- Now functions to write it in specific formats+formatObject :: (DiscreteAproxable obj aprox) =>+ ℝ -- ^ Resolution+ -> (aprox -> Text) -- ^ File Format (Function that formats)+ -> obj -- ^ Object to render+ -> Text -- ^ Resulting lazy ByteString +formatObject res format = format . discreteAprox res+ writeSVG res = writeObject res PolylineFormats.svg writeSTL res = writeObject res TriangleMeshFormats.stl++writeBinSTL res file obj = LBS.writeFile file $ TriangleMeshFormats.binaryStl $ discreteAprox res obj+ 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)+writeSCAD3 res filename obj = writeFile filename $ SymbolicFormats.scad3 res obj+writeSCAD2 res filename obj = writeFile filename $ SymbolicFormats.scad2 res obj +writePNG res = writeObject' res ImageFormatCodecs.savePngImage {- renderRaw :: ℝ3 -> ℝ3 -> ℝ -> String -> Obj3 -> IO()
Graphics/Implicit/Export/MarchingSquares.hs view
@@ -6,24 +6,31 @@ import Graphics.Implicit.Definitions import Control.Parallel.Strategies (using, parList, rdeepseq) import Debug.Trace+import Data.VectorSpace +both :: (a -> b) -> (a,a) -> (b,b)+both f (x,y) = (f x, f y)+ -- | getContour gets a polyline describe the edge of your 2D -- object. It's really the only function in this file you need -- to care about from an external perspective. getContour :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [Polyline]-getContour (x1, y1) (x2, y2) (dx, dy) obj = +getContour p1 p2 d obj = let -- How many steps will we take on each axis?- nx = fromIntegral $ ceiling $ (x2 - x1) / dx- ny = fromIntegral $ ceiling $ (y2 - y1) / dy+ n@(nx,ny) = (fromIntegral . ceiling) `both` ((p2 ^-^ p1) ⋯/ d) -- Divide it up and compute the polylines+ gridPos :: (Int,Int) -> (Int,Int) -> ℝ2+ gridPos (nx,ny) (mx,my) = let p = ( fromIntegral mx / fromIntegral nx+ , fromIntegral my / fromIntegral ny)+ in p1 ^+^ (p2 ^-^ p1) ⋯* p linesOnGrid :: [[[Polyline]]]- linesOnGrid = [[getSquareLineSegs - (x1 + (x2 - x1)*mx/nx, y1 + (y2 - y1)*my/ny)- (x1 + (x2 - x1)*(mx+1)/nx, y1 + (y2 - y1)*(my+1)/ny)- obj- | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]+ linesOnGrid = [[getSquareLineSegs+ (gridPos n (mx,my))+ (gridPos n (mx+1,my+1))+ obj+ | mx <- [0.. nx-1] ] | my <- [0..ny-1] ] -- Cleanup, cleanup, everybody cleanup! -- (We connect multilines, delete redundant vertices on them, etc) multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLinesDC $ linesOnGrid@@ -31,15 +38,15 @@ multilines getContour2 :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [Polyline]-getContour2 (x1, y1) (x2, y2) (dx, dy) obj = +getContour2 p1@(x1, y1) p2@(x2, y2) d obj = let -- How many steps will we take on each axis?- nx = fromIntegral $ ceiling $ (x2 - x1) / dx- ny = fromIntegral $ ceiling $ (y2 - y1) / dy+ n@(nx,ny) = (fromIntegral . ceiling) `both` ((p2 ^-^ p1) ⋯/ d) -- 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.+ fromGrid (mx, my) = let p = (mx/nx, my/ny)+ in (p1 ^+^ (p2 ^-^ p1) ⋯/ p)+ toGrid (x,y) = (floor $ nx*(x-x1)/(x2-x1), floor $ ny*(y-y1)/(y2-y1))+ -- Evaluate obj on a grid, in parallel. valsOnGrid :: [[ℝ]] valsOnGrid = [[ obj (fromGrid (mx, my)) | mx <- [0.. nx-1] ] | my <- [0..ny-1] ] `using` parList rdeepseq@@ -56,13 +63,13 @@ multilines --- | This function gives line segmensts to divde negative interior+-- | This function gives line segments to divide negative interior -- regions and positive exterior ones inside a square, based on its -- values at its vertices. -- It is based on the linearly-interpolated marching squares algorithm. getSquareLineSegs :: ℝ2 -> ℝ2 -> Obj2 -> [Polyline]-getSquareLineSegs (x1, y1) (x2, y2) obj = +getSquareLineSegs p1@(x1, y1) p2@(x2, y2) obj = let (x,y) = (x1, y1)
Graphics/Implicit/Export/NormedTriangleMeshFormats.hs view
@@ -1,18 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+ -- 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+import Graphics.Implicit.Export.TextBuilderUtils -obj normedtriangles = text++obj normedtriangles = toLazyText $ vertcode <> normcode <> trianglecode where -- A vertex line; v (0.0, 0.0, 1.0) = "v 0.0 0.0 1.0\n"- v :: ℝ3 -> String- v (x,y,z) = "v " ++ show x ++ " " ++ show y ++ " " ++ show z ++ "\n"+ v :: ℝ3 -> Builder+ v (x,y,z) = "v " <> bf x <> " " <> bf y <> " " <> bf z <> "\n" -- A normal line; n (0.0, 0.0, 1.0) = "vn 0.0 0.0 1.0\n"- n :: ℝ3 -> String- n (x,y,z) = "vn " ++ show x ++ " " ++ show y ++ " " ++ show z ++ "\n"+ n :: ℝ3 -> Builder+ n (x,y,z) = "vn " <> bf x <> " " <> bf y <> " " <> bf z <> "\n" verts = do -- extract the vertices for each triangle -- recall that a normed triangle is of the form ((vert, norm), ...)@@ -24,17 +28,13 @@ ((_,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+ vertcode = mconcat $ map v verts+ normcode = mconcat $ map n norms+ trianglecode = mconcat $ 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---+ vta = buildInt n+ vtb = buildInt (n+1)+ vtc = buildInt (n+2)+ return $ "f " <> vta <> " " <> vtb <> " " <> vtc <> " " <> "\n"
Graphics/Implicit/Export/PolylineFormats.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU GPL, see LICENSE@@ -6,49 +7,74 @@ import Graphics.Implicit.Definitions -import Text.Printf (printf)+import Graphics.Implicit.Export.TextBuilderUtils -svg :: [Polyline] -> String-svg polylines = text- where- -- SVG is stupidly laid out... (0,0) is the top left corner- (xs, ys) = unzip (concat polylines)- (minx, maxy) = (minimum xs, maximum ys)- transform (x,y) = (x-minx, maxy - y)- polylines2 = map (map transform) polylines- svglines = concat $ map (\line -> - " <polyline points=\"" - ++ concat (map (\(x,y) -> " " ++ show x ++ "," ++ show y) line)- ++ "\" style=\"stroke:rgb(0,0,255);stroke-width:1;fill:none;\"/> \n" ) - polylines2 - text = "<svg xmlns=\"http://www.w3.org/2000/svg\" version=\"1.1\"> \n" - ++ svglines - ++ "</svg> "+import Text.Blaze.Svg.Renderer.Text (renderSvg)+import Text.Blaze.Svg+import Text.Blaze.Svg11 ((!),docTypeSvg,g,polyline,toValue)+import Text.Blaze.Internal (stringValue)+import qualified Text.Blaze.Svg11.Attributes as A -hacklabLaserGCode :: [Polyline] -> String-hacklabLaserGCode polylines = text- where- gcodeHeader = - "(generated by ImplicitCAD, based of hacklab wiki example)\n"- ++"M63 P0 (laser off)\n"- ++"G0 Z0.002 (laser off)\n"- ++"G21 (units=mm)\n"- ++"F400 (set feedrate)\n"- ++"M3 S1 (enable laser)\n"- ++"\n"- gcodeFooter = - "M5 (disable laser)\n"- ++"G00 X0.0 Y0.0 (move to 0)\n"- ++"M2 (end)"- showF n = printf "%.4f" n- gcodeXY :: ℝ2 -> [Char]- gcodeXY (x,y) = "X"++ showF x ++" Y"++ showF y - interpretPolyline (start:others) = - "G00 "++ gcodeXY start ++ "\n"- ++ "M62 P0 (laser on)\n"- ++ concat (map (\p -> "G01 " ++ (gcodeXY p) ++ "\n") others)- ++ "M63 P0 (laser off)\n\n"- text = gcodeHeader- ++ (concat $ map interpretPolyline polylines)- ++ gcodeFooter+import Data.List (foldl',intersperse)+import qualified Data.List as List +svg :: [Polyline] -> Text+svg plines = renderSvg . svg11 . svg' $ plines+ where + (xmin, xmax, ymin, ymax) = (minimum xs, maximum xs, minimum ys, maximum ys)+ where (xs,ys) = unzip (concat plines)+ + svg11 content = docTypeSvg ! A.version "1.1" + ! A.width (stringValue $ show (xmax-xmin) ++ "mm")+ ! A.height (stringValue $ show (ymax-ymin) ++ "mm")+ ! A.viewbox (stringValue $ concat . intersperse " " . map show $ [xmin, xmax, ymin, ymax])+ $ content+ -- The reason this isn't totally straightforwards is that svg has different coordinate system+ -- and we need to compute the requisite translation.+ svg' [] = mempty + -- When we have a known point, we can compute said transformation:+ svg' polylines = thinBlueGroup $ mapM_ poly polylines+ -- Otherwise, if we don't have a point to start out with, skip this polyline:+ svg' ([]:rest) = svg' rest++ poly line = polyline ! A.points pointList + where pointList = toValue $ toLazyText $ mconcat [bf (x-xmin) <> "," <> bf (ymax - y) <> " " | (x,y) <- line]++ -- Instead of setting styles on every polyline, we wrap the lines in a group element and set the styles on it:+ thinBlueGroup = g ! A.stroke "rgb(0,0,255)" ! A.strokeWidth "1" ! A.fill "none" -- obj++hacklabLaserGCode :: [Polyline] -> Text+hacklabLaserGCode polylines = toLazyText $ gcodeHeader <> mconcat (map interpretPolyline orderedPoylines) <> gcodeFooter+ where + orderedPoylines = + snd . unzip + . List.sortBy (\(a,_) (b, _) -> compare a b)+ . map (\x -> (polylineRadius x, x))+ $ polylines+ polylineRadius [] = 0+ polylineRadius polyline = max (xmax - xmin) (ymax - ymin) where+ ((xmin, xmax), (ymin, ymax)) = polylineRadius' polyline+ polylineRadius' [(x,y)] = ((x,x),(y,y))+ polylineRadius' ((x,y):ps) = ((min x xmin,max x xmax),(min y ymin, max y ymax))+ where ((xmin, xmax), (ymin, ymax)) = polylineRadius' ps+ gcodeHeader = mconcat [+ "(generated by ImplicitCAD, based of hacklab wiki example)\n"+ ,"M63 P0 (laser off)\n"+ ,"G0 Z0.002 (laser off)\n"+ ,"G21 (units=mm)\n"+ ,"F400 (set feedrate)\n"+ ,"M3 S1 (enable laser)\n\n"]+ gcodeFooter = mconcat [+ "M5 (disable laser)\n"+ ,"G00 X0.0 Y0.0 (move to 0)\n"+ ,"M2 (end)"]+ gcodeXY :: ℝ2 -> Builder+ gcodeXY (x,y) = mconcat ["X", buildTruncFloat x, " Y", buildTruncFloat y]+ + interpretPolyline (start:others) = mconcat [+ "G00 ", gcodeXY start+ ,"\nM62 P0 (laser on)\n"+ ,mconcat [ "G01 " <> gcodeXY point <> "\n" | point <- others]+ ,"M63 P0 (laser off)\n\n"+ ]+ interpretPolyline [] = mempty
+ Graphics/Implicit/Export/RayTrace.hs view
@@ -0,0 +1,216 @@++{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-}++module Graphics.Implicit.Export.RayTrace where++import Graphics.Implicit.ObjectUtil+import Graphics.Implicit.Definitions+import Graphics.Implicit.Export.Definitions+import Codec.Picture+import Control.Monad+import Data.VectorSpace +import Data.AffineSpace +import Data.Cross++import Debug.Trace++-- Definitions++data Camera = Camera ℝ3 ℝ3 ℝ3 ℝ+ deriving Show+data Ray = Ray ℝ3 ℝ3+ deriving Show+data Light = Light ℝ3 ℝ+ deriving Show+data Scene = Scene Obj3 Color [Light] Color++type Color = PixelRGBA8+color r g b a = PixelRGBA8 r g b a+dynamicImage = ImageRGBA8++-- Math++d a b = magnitude (b-a)++s `colorMult` (PixelRGBA8 a b c d) = color (s `mult` a) (s `mult` b) (s `mult` c) d+ where + bound = max 0 . min 254+ mult a b = fromIntegral . round . bound $ a * fromIntegral b++average :: [Color] -> Color+average l = + let + ((rs, gs), (bs, as)) = (\(a,b) -> (unzip a, unzip b)) $ unzip $ map + (\(PixelRGBA8 r g b a) -> ((fromIntegral r, fromIntegral g), (fromIntegral b, fromIntegral a)))+ l :: (([ℝ], [ℝ]), ([ℝ],[ℝ]))+ n = fromIntegral $ length l :: ℝ+ (r, g, b, a) = (sum rs/n, sum gs/n, sum bs/n, sum as/n)+ in PixelRGBA8+ (fromIntegral . round $ r) (fromIntegral . round $ g) (fromIntegral . round $ b) (fromIntegral . round $ a)++-- Ray Utilities++cameraRay :: Camera -> ℝ2 -> Ray+cameraRay (Camera p vx vy f) (x,y) =+ let+ v = vx `cross3` vy+ p' = p ^+^ f*^v ^+^ x*^vx ^+^ y*^vy+ n = normalized (p' ^-^ p)+ in+ Ray p' n++rayFromTo :: ℝ3 -> ℝ3 -> Ray+rayFromTo p1 p2 = Ray p1 (normalized $ p2 ^-^ p1)++rayBounds :: Ray -> (ℝ3, ℝ3) -> ℝ2+rayBounds ray box =+ let+ Ray (cPx, cPy, cPz) cameraV@(cVx, cVy, cVz) = ray+ ((x1,y1,z1),(x2,y2,z2)) = box+ xbounds = [(x1 - cPx)/cVx, (x2-cPx)/cVx]+ ybounds = [(y1-cPy)/cVy, (y2-cPy)/cVy]+ zbounds = [(z1-cPz)/cVz, (z2-cPz)/cVz]+ lower = maximum [minimum xbounds, minimum ybounds, minimum zbounds]+ upper = minimum [maximum xbounds, maximum ybounds, maximum zbounds]+ in+ (lower, upper)++-- Intersection+++intersection :: Ray -> ((ℝ,ℝ), ℝ) -> ℝ -> Obj3 -> Maybe ℝ3+intersection r@(Ray p v) ((a, aval),b) res obj =+ let+ step = + if aval/(4::ℝ) > res then res+ else if aval/(2::ℝ) > res then res/(2 :: ℝ)+ else res/(10 :: ℝ)+ a' = a + step+ a'val = obj (p ^+^ a'*^v)+ in if a'val < 0+ then + let a'' = refine (a,a') (\s -> obj (p ^+^ s*^v))+ in Just (p ^+^ a''*^v)+ else if a' < b+ then intersection r ((a',a'val), b) res obj+ else Nothing++refine :: ℝ2 -> (ℝ -> ℝ) -> ℝ+refine (a, b) obj = + let+ (aval, bval) = (obj a, obj b)+ in if bval < aval+ then refine' 10 (a, b) (aval, bval) obj+ else refine' 10 (b, a) (aval, bval) obj++refine' :: Int -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ+refine' 0 (a, b) _ _ = a+refine' n (a, b) (aval, bval) obj = + let+ mid = (a+b)/(2::ℝ)+ midval = obj mid+ in+ if midval == 0+ then mid+ else if midval < 0+ then refine' (pred n) (a, mid) (aval, midval) obj+ else refine' (pred n) (mid, b) (midval, bval) obj++intersects a b c d = case intersection a b c d of+ Nothing -> False+ Just _ -> True++-- Trace++traceRay :: Ray -> ℝ -> (ℝ3, ℝ3) -> Scene -> Color+traceRay ray@(Ray cameraP cameraV) step box (Scene obj objColor lights defaultColor) =+ let+ (a,b) = rayBounds ray box+ in case intersection ray ((a, obj (cameraP ^+^ a*^cameraV)), b) step obj of+ Just p -> flip colorMult objColor $ (sum $ [0.2] ++ do+ Light lightPos lightIntensity <- lights+ let+ ray'@(Ray _ v) = rayFromTo p lightPos+ v' = normalized v+ guard . not $ intersects ray' ((0, obj p),20) step obj+ let+ pval = obj p+ step = 0.1 :: ℝ+ dirDeriv :: ℝ3 -> ℝ+ dirDeriv v = (obj (p ^+^ step*^v) ^-^ pval)/step+ deriv = (dirDeriv (1,0,0), dirDeriv (0,1,0), dirDeriv (0,0,1))+ normal = normalized $ deriv+ unitV = normalized $ v'+ proj a b = (a⋅b)*^b+ dist = d p lightPos+ illumination = (max 0 (normal ⋅ unitV)) * lightIntensity * (25 /dist)+ rV = + let+ normalComponent = proj v' normal+ parComponent = v' - normalComponent+ in+ normalComponent - parComponent + return $ illumination*(3 + 0.3*(abs $ rV ⋅ cameraV)^2)+ )+ Nothing -> defaultColor++instance DiscreteAproxable SymbolicObj3 DynamicImage where+ discreteAprox res symbObj = dynamicImage $ generateImage pixelRenderer (round w) (round h)+ where+ (w,h) = (150, 150) :: ℝ2+ obj = getImplicit3 symbObj+ box@((x1,y1,z1), (x2,y2,z2)) = getBox3 symbObj+ av :: ℝ -> ℝ -> ℝ+ av a b = (a+b)/(2::ℝ)+ avY = av y1 y2+ avZ = av z1 z2+ deviation = maximum [abs $ y1 - avY, abs $ y2 - avY, abs $ z1 - avZ, abs $ z2 - avZ]+ camera = Camera (x1-deviation*(2.2::ℝ), avY, avZ) (0, -1, 0) (0,0, -1) 1.0+ lights = [Light (x1-deviation*(1.5::ℝ), y1 - (0.4::ℝ)*(y2-y1), avZ) ((0.03::ℝ)*deviation) ]+ scene = Scene obj (PixelRGBA8 200 200 230 255) lights (PixelRGBA8 255 255 255 0)+ pixelRenderer :: Int -> Int -> Color+ pixelRenderer a b = renderScreen + ((fromIntegral a :: ℝ)/w - (0.5::ℝ)) ((fromIntegral b :: ℝ)/h - (0.5 ::ℝ))+ renderScreen :: ℝ -> ℝ -> Color+ renderScreen a b =+ let+ ray = cameraRay camera (a,b)+ in + average $ [+ traceRay + (cameraRay camera ((a,b) ^+^ ( 0.25/w, 0.25/h)))+ 2 box scene,+ traceRay + (cameraRay camera ((a,b) ^+^ (-0.25/w, 0.25/h)))+ 0.5 box scene,+ traceRay + (cameraRay camera ((a,b) ^+^ (0.25/w, -0.25/h)))+ 0.5 box scene,+ traceRay + (cameraRay camera ((a,b) ^+^ (-0.25/w,-0.25/h)))+ 0.5 box scene+ ]+++instance DiscreteAproxable SymbolicObj2 DynamicImage where+ discreteAprox res symbObj = dynamicImage $ generateImage pixelRenderer (round w) (round h)+ where+ (w,h) = (150, 150) :: ℝ2+ obj = getImplicit2 symbObj+ (p1@(x1,y1), p2@(x2,y2)) = getBox2 symbObj+ (dx, dy) = p2 ^-^ p1+ dxy = max dx dy+ pixelRenderer :: Int -> Int -> Color+ pixelRenderer a b = color+ where+ xy a b = ((x1,y2) .-^ (dxy-dx, dy-dxy)^/2) .+^ dxy*^(a/w, -b/h)+ s = 0.25 :: ℝ+ (a', b') = (realToFrac a, realToFrac b)+ color = average [objColor $ xy a' b', objColor $ xy a' b',+ objColor $ xy (a'+s) (b'+s),+ objColor $ xy (a'-s) (b'-s),+ objColor $ xy (a'+s) (b'+s),+ objColor $ xy (a'-s) (b'-s)]+ objColor p = if obj p < 0 then PixelRGBA8 150 150 160 255 else PixelRGBA8 255 255 255 0++
Graphics/Implicit/Export/Render.hs view
@@ -9,6 +9,7 @@ import Graphics.Implicit.Definitions import Graphics.Implicit.Export.Render.Definitions+import Data.VectorSpace -- Here's the plan for rendering a cube (the 2D case is trivial): @@ -31,7 +32,7 @@ import Graphics.Implicit.Export.Render.GetLoops (getLoops) --- (4) We tesselate the loops, using a mixtur of triangles and squares+-- (4) We tesselate the loops, using a mixture of triangles and squares import Graphics.Implicit.Export.Render.TesselateLoops (tesselateLoop) @@ -48,12 +49,29 @@ -- The actual code is just a bunch of ugly argument passing. -- Utility functions can be found at the end. +-- For efficiency, we need to avoid looking things up in other lists+-- (since they're 3D, it's an O(n³) operation...). So we need to make+-- our algorithms "flow" along the data structure instead of accessing+-- within it. To do this we use the ParallelListComp GHC extention.++-- We also compute lots of things in advance and pass them in as arguments,+-- to reduce redundant computations.++-- All in all, this is kind of ugly. But it is necessary.++-- Note: As far as the actual results of the rendering algorithm, nothing in+-- this file really matters. All the actual decisions about how to build+-- the mesh are abstracted into the imported files. They are likely what+-- you are interested in.++-- For the 2D case, we need one last thing, cleanLoopsFromSegs:++import Graphics.Implicit.Export.Render.HandlePolylines ( cleanLoopsFromSegs )+ getMesh :: ℝ3 -> ℝ3 -> ℝ -> Obj3 -> TriangleMesh-getMesh (x1, y1, z1) (x2, y2, z2) res obj = +getMesh p1@(x1,y1,z1) p2@(x2,y2,z2) res obj = let- dx = x2-x1- dy = y2-y1- dz = z2-z1+ (dx,dy,dz) = p2 ^-^ p1 -- How many steps will we take on each axis? nx = ceiling $ dx / res@@ -120,22 +138,8 @@ |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)) -- -}+ ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq)+ segsY = [[[ map2 (inj2 y0) $ getSegs (x0,z0) (x1,z1) (obj *$* y0) (objX0Y0Z0,objX1Y0Z0,objX0Y0Z1,objX1Y0Z1)@@ -146,23 +150,7 @@ |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))- -- -}+ ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq) segsX = [[[ @@ -175,23 +163,7 @@ |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) ) -- -}+ ] `using` (parListChunk (max 1 $ div nz 32) rdeepseq) -- (3) & (4) : get and tesselate loops @@ -216,12 +188,75 @@ ]| 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 ++getContour :: ℝ2 -> ℝ2 -> ℝ -> Obj2 -> [Polyline]+getContour p1@(x1, y1) p2@(x2, y2) res obj = + let+ (dx,dy) = p2 ^-^ p1++ -- How many steps will we take on each axis?+ nx = ceiling $ dx / res+ ny = ceiling $ dy / res++ rx = dx/fromIntegral nx+ ry = dy/fromIntegral ny++ l ! (a,b) = l !! b !! a++ pYs = [ y1 + ry*n | n <- [0.. fromIntegral ny] ]+ pXs = [ x1 + rx*n | n <- [0.. fromIntegral nx] ]+++ {-# INLINE par2DList #-}+ par2DList lenx leny f = + [[ f+ (\n -> x1 + rx*fromIntegral (mx+n)) mx + (\n -> y1 + ry*fromIntegral (my+n)) my+ | mx <- [0..lenx] ] | my <- [0..leny] ]+ `using` (parListChunk (max 1 $ div leny 32) rdeepseq)+++ -- Evaluate obj to avoid waste in mids, segs, later.++ objV = par2DList (nx+2) (ny+2) $ \x _ y _ -> obj (x 0, y 0)++ -- (1) Calculate mid poinsts on X, Y, and Z axis in 3D space.++ midsY = [[+ interpolate (y0, objX0Y0) (y1, objX0Y1) (obj $* x0) res+ | x0 <- pXs | objX0Y0 <- objY0 | objX0Y1 <- objY1+ ]| y0 <- pYs | y1 <- tail pYs | objY0 <- objV | objY1 <- tail objV+ ] `using` (parListChunk (max 1 $ div ny 32) rdeepseq)++ midsX = [[+ interpolate (x0, objX0Y0) (x1, objX1Y0) (obj *$ y0) res+ | x0 <- pXs | x1 <- tail pXs | objX0Y0 <- objY0 | objX1Y0 <- tail objY0+ ]| y0 <- pYs | objY0 <- objV + ] `using` (parListChunk (max 1 $ div ny 32) rdeepseq)++ -- Calculate segments for each side++ segs = [[ + getSegs (x0,y0) (x1,y1) obj+ (objX0Y0, objX1Y0, objX0Y1, objX1Y1)+ (midA0, midA1, midB0, midB1)+ |x0<-pXs|x1<-tail pXs|midB0<-mX'' |midB1<-mX'T |midA0<-mY'' |midA1<-tail mY''+ |objX0Y0<-objY0|objX1Y0<-tail objY0|objX0Y1<-objY1|objX1Y1<-tail objY1+ ]|y0<-pYs|y1<-tail pYs|mX'' <-midsX|mX'T <-tail midsX|mY'' <-midsY+ |objY0 <- objV | objY1 <- tail objV+ ] `using` (parListChunk (max 1 $ div ny 32) rdeepseq)++ in cleanLoopsFromSegs $ concat $ concat $ segs -- (5) merge squares, etc++++ -- silly utility functions inj1 a (b,c) = (a,b,c)@@ -231,6 +266,10 @@ infixr 0 $** infixr 0 *$* infixr 0 **$+infixr 0 $*+infixr 0 *$+f $* a = \b -> f (a,b)+f *$ b = \a -> f (a,b) f $** a = \(b,c) -> f (a,b,c) f *$* b = \(a,c) -> f (a,b,c) f **$ c = \(a,b) -> f (a,b,c)
Graphics/Implicit/Export/Render/Definitions.hs view
@@ -6,7 +6,15 @@ import Graphics.Implicit.Definitions import Control.DeepSeq +-- We want a format that can represent squares/quads and triangles.+-- So that we can merge squares and thereby reduces triangles.++-- Regarding Sq: Sq Basis@(b1,b2,b3) (Height on b3) +-- (b1 pos 1, b2 pos 1) (b1 pos 2, b2 pos 2)+ data TriSquare = Sq (ℝ3,ℝ3,ℝ3) ℝ ℝ2 ℝ2 | Tris [Triangle]++-- For use with Parallel.Strategies later instance NFData TriSquare where rnf (Sq b z xS yS) = rnf (b,z,xS,yS)
Graphics/Implicit/Export/Render/GetLoops.hs view
@@ -3,17 +3,58 @@ module Graphics.Implicit.Export.Render.GetLoops (getLoops) where ++-- The goal of getLoops is, if you can imagine, extracting loops+-- from a list of segments.++-- The input is a list of segments+-- the output a list of loops, where each loop is a list of +-- segments, which each piece representing a "side".++-- For example:+-- Given input [[1,2],[5,1],[3,4,5]] +-- notice that there is a loop 1,2,3,4,5... <repeat>+-- But we give the output [ [1,2], [3,4,5], [5,1] ]+-- so that we have the loop, and also knowledge of how+-- the list is built (the "sides" of it).+ getLoops :: Eq a => [[a]] -> [[[a]]]++-- We will be actually doing the loop extraction with+-- getLoops'++-- getLoops' has a first argument of the segments as before,+-- but a *second argument* which is the loop presently being+-- built.++-- so we begin with the "building loop" being empty.+ getLoops a = getLoops' a [] + getLoops' :: Eq a => [[a]] -> [[a]] -> [[[a]]] +-- Obviously if there aren't any segments,+-- and the "building loop" is empty, +-- we produce no loops.+ getLoops' [] [] = [] +-- And if the building loop is empty,+-- we stick the first segment we have onto it+-- to give us something to build on.+ getLoops' (x:xs) [] = getLoops' xs [x] +-- A loop is finished if its start and end are the same.+-- In this case, we return it and empty the building loop.+ getLoops' segs workingLoop | head (head workingLoop) == last (last workingLoop) = workingLoop : getLoops' segs []++-- Finally, we search for pieces that can continue the working loop,+-- and stick one on if we find it.+-- Otherwise... something is really screwed up. getLoops' segs workingLoop = let
Graphics/Implicit/Export/Render/GetSegs.hs view
@@ -5,27 +5,65 @@ import Graphics.Implicit.Definitions import Graphics.Implicit.Export.Render.RefineSegs (refine)+import Graphics.Implicit.Export.Util (centroid)+import Data.VectorSpace -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)+{- The goal of getSegs is to create polylines to separate + the interior and exterior vertices of a square intersectiong+ an object described by an implicit function. + O.....O O.....O+ : : : :+ : * : ,--*+ * : => *-- :+ : : : :+ #.....# #.....#++ An interior point is one at which obj is negative.+ + What are all the variables?+ ===========================++ To allow data sharing, lots of values we + could calculate are instead arguments.+++ positions obj values+ --------- ----------++ (x1,y2) .. (x2,y2) obj x1y2 .. x2y2+ : : => : :+ (x1,y1) .. (x2,y1) x1y1 .. x2y2+++ mid points+ ----------++ (midy2V, y2)+ = midy2++ ......*.....+ : :+ (x1, midx1V) * * (x2, midx2V)+ = midx1 : : = midx2+ :....*.....:++ (midy1V, y1)+ = midy1++-}+ getSegs :: ℝ2 -> ℝ2 -> Obj2 -> (ℝ,ℝ,ℝ,ℝ) -> (ℝ,ℝ,ℝ,ℝ) -> [Polyline]-{-- INLINE getSegs #-}-getSegs (x1, y1) (x2, y2) obj (x1y1, x2y1, x1y2, x2y2) (midx1V,midx2V,midy1V,midy2V) = +{-- # INLINE getSegs #-}++getSegs p1 p2 obj (x1y1, x2y1, x1y2, x2y2) (midx1V,midx2V,midy1V,midy2V) = let - (x,y) = (x1, y1)+ (x,y) = p1 - -- Let's evlauate obj at a few points...- c = obj ((x1+x2)/2, (y1+y2)/2)+ -- Let's evaluate obj at a few points...+ c = obj (centroid [p1,p2]) - dx = x2 - x1- dy = y2 - y1+ (dx,dy) = p2 ^-^ p1 res = sqrt (dx*dy) midx1 = (x, midx1V )@@ -35,45 +73,88 @@ notPointLine (p1:p2:[]) = p1 /= p2 + -- takes straight lines between mid points and subdivides them to+ -- account for sharp corners, etc.+ in map (refine res obj) . filter (notPointLine) $ case (x1y2 <= 0, x2y2 <= 0,- x1y1 <= 0, x2y1 <= 0) of+ 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...+ -- An important point here is orientation. If you imagine going along a+ -- generated segment, the interior should be on the left-hand side.++ -- Empty Cases+ (True, True, True, True) -> []+ (False, False, False, False) -> []++ -- Horizontal Cases+ (True, True, False, False) -> [[midx1, midx2]]+ (False, False, True, True) -> [[midx2, midx1]]++ -- Vertical Cases+ (False, True, False, True) -> [[midy2, midy1]]+ (True, False, True, False) -> [[midy1, midy2]]++ -- Corner Cases+ (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]]++ -- Dual Corner Cases+ (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]]+++-- A convenience function, we don't actually care too much about++{-- # INLINE getSegs' #-}++getSegs' (x1, y1) (x2, y2) obj (midx1V,midx2V,midy1V,midy2V) = + let+ x1y1 = obj (x1, y1)+ x2y1 = obj (x2, y1)+ x1y2 = obj (x1, y2)+ x2y2 = obj (x2, y2)+ in+ getSegs (x1, y1) (x2, y2) obj (x1y1, x2y1, x1y2, x2y2) (midx1V,midx2V,midy1V,midy2V)
+ Graphics/Implicit/Export/Render/HandlePolylines.hs view
@@ -0,0 +1,108 @@+-- Implicit CAD. Copyright (C) 2012, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++module Graphics.Implicit.Export.Render.HandlePolylines (cleanLoopsFromSegs) where++import Graphics.Implicit.Definitions+import Graphics.Implicit.Export.Render.Definitions+import GHC.Exts (groupWith)+import Data.List (sortBy)+import Data.VectorSpace ++cleanLoopsFromSegs :: [Polyline] -> [Polyline]+cleanLoopsFromSegs =+ map reducePolyline+ . joinSegs+ . filter polylineNotNull+++joinSegs :: [Polyline] -> [Polyline]+joinSegs [] = []+joinSegs (present:remaining) =+ let+ findNext ((p3:ps):segs) = if p3 == last present then (Just (p3:ps), segs) else+ if last ps == last present then (Just (reverse $ p3:ps), segs) else+ case findNext segs of (res1,res2) -> (res1,(p3:ps):res2)+ findNext [] = (Nothing, [])+ in+ case findNext remaining of+ (Nothing, _) -> present:(joinSegs remaining)+ (Just match, others) -> joinSegs $ (present ++ tail match): others++reducePolyline ((x1,y1):(x2,y2):(x3,y3):others) = + if (x1,y1) == (x2,y2) then reducePolyline ((x2,y2):(x3,y3):others) else+ if abs ( (y2-y1)/(x2-x1) - (y3-y1)/(x3-x1) ) < 0.0001 + || ( (x2-x1) == 0 && (x3-x1) == 0 && (y2-y1)*(y3-y1) > 0)+ then reducePolyline ((x1,y1):(x3,y3):others)+ else (x1,y1) : reducePolyline ((x2,y2):(x3,y3):others)+reducePolyline ((x1,y1):(x2,y2):others) = + if (x1,y1) == (x2,y2) then reducePolyline ((x2,y2):others) else (x1,y1):(x2,y2):others+reducePolyline l = l++polylineNotNull (a:l) = not (null l)+polylineNotNull [] = False++++{-cleanLoopsFromSegs = + connectPolys+ -- . joinSegs+ . filter (not . degeneratePoly)+ +polylinesFromSegsOnGrid = undefined++degeneratePoly [] = True+degeneratePoly [a,b] = a == b+degeneratePoly _ = False++data SegOrPoly = Seg (ℝ2) ℝ ℝ2 -- Basis, shift, interval+ | Poly [ℝ2]++isSeg (Seg _ _ _) = True+isSeg _ = False++toSegOrPoly :: Polyline -> SegOrPoly+toSegOrPoly [a, b] = Seg v (a⋅vp) (a⋅v, b⋅v)+ where+ v@(va, vb) = normalized (b ^-^ a)+ vp = (-vb, va)+toSegOrPoly ps = Poly ps++fromSegOrPoly :: SegOrPoly -> Polyline+fromSegOrPoly (Seg v@(va,vb) s (a,b)) = [a*^v ^+^ t, b*^v ^+^ t]+ where t = s*^(-vb, va)+fromSegOrPoly (Poly ps) = ps++joinSegs :: [Polyline] -> [Polyline]+joinSegs = map fromSegOrPoly . joinSegs' . map toSegOrPoly++joinSegs' :: [SegOrPoly] -> [SegOrPoly]+joinSegs' segsOrPolys = polys ++ concat (map joinAligned aligned) where+ polys = filter (not.isSeg) segsOrPolys+ segs = filter isSeg segsOrPolys+ aligned = groupWith (\(Seg basis p _) -> (basis,p)) segs++joinAligned segs@((Seg b z _):_) = mergeAdjacent orderedSegs where+ orderedSegs = sortBy (\(Seg _ _ (a1,_)) (Seg _ _ (b1,_)) -> compare a1 b1) segs+ mergeAdjacent (pres@(Seg _ _ (x1a,x2a)) : next@(Seg _ _ (x1b,x2b)) : others) =+ if x2a == x1b+ then mergeAdjacent ((Seg b z (x1a,x2b)): others)+ else pres : mergeAdjacent (next : others)+ mergeAdjacent a = a+joinAligned [] = []++connectPolys :: [Polyline] -> [Polyline]+connectPolys [] = []+connectPolys (present:remaining) =+ let+ findNext (ps@(p:_):segs) = + if p == last present+ then (Just ps, segs)+ else (a, ps:b) where (a,b) = findNext segs+ findNext [] = (Nothing, [])+ in+ case findNext remaining of+ (Nothing, _) -> present:(connectPolys remaining)+ (Just match, others) -> connectPolys $ (present ++ tail match): others++-}
Graphics/Implicit/Export/Render/HandleSquares.hs view
@@ -5,63 +5,127 @@ import Graphics.Implicit.Definitions import Graphics.Implicit.Export.Render.Definitions-import qualified Graphics.Implicit.SaneOperators as S import GHC.Exts (groupWith)+import Data.List (sortBy)+import Data.VectorSpace +-- We want small meshes. Essential to this, is getting rid of triangles.+-- We secifically mark quads in tesselation (refer to Graphics.Implicit.+-- Export.Render.Definitions, Graphics.Implicit.Export.Render.TesselateLoops)+-- So that we can try and merge them together.++{- Core idea of mergedSquareTris:++ Many Quads on Plane + ____________ + | | | |+ |____|____| |+ |____|____|__|++ | joinXaligned+ v + ____________ + | | |+ |_________|__|+ |_________|__|++ | joinYaligned+ v + ____________ + | | |+ | | |+ |_________|__|++ | joinXaligned (presently disabled)+ v + ____________ + | |+ | |+ |____________|++ | squareToTri+ v + ____________ + |\ |+ | ---------- |+ |___________\|++-}+ mergedSquareTris sqTris = let+ -- We don't need to do any work on triangles. They'll just be part of+ -- the list of triangles we give back. So, the triangles coming from+ -- triangles... triTriangles = concat $ map (\(Tris a) -> a) $ filter isTris sqTris + -- We actually want to work on the quads, so we find those squares = filter (not . isTris) sqTris+ -- Collect ones that are on the same plane. planeAligned = groupWith (\(Sq basis z _ _) -> (basis,z)) squares+ -- For each plane:+ -- Select for being the same range on X and then merge them on Y+ -- Then vice versa. joined = map - ( concat . (map joinYaligned) . groupWith (\(Sq _ _ _ yS) -> yS)+ ( -- concat . (map joinXaligned) . groupWith (\(Sq _ _ xS _) -> xS)+ concat . (map joinYaligned) . groupWith (\(Sq _ _ _ yS) -> yS) . concat . (map joinXaligned) . groupWith (\(Sq _ _ xS _) -> xS)) planeAligned+ -- Merge them back together, and we have the desired reult! finishedSquares = concat joined in+ -- merge them to triangles, and combine with the original triagneles. triTriangles ++ concat (map squareToTri finishedSquares) +-- And now for a bunch of helper functions that do the heavy lifting...+ isTris (Tris _) = True isTris _ = False -joinXaligned (pres@(Sq b z xS (y1,y2)):sqs) = ++joinXaligned quads@((Sq b z xS _):_) = 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+ orderedQuads = sortBy + (\(Sq _ _ _ (ya,_)) (Sq _ _ _ (yb,_)) -> compare ya yb)+ quads+ mergeAdjacent (pres@(Sq _ _ _ (y1a,y2a)) : next@(Sq _ _ _ (y1b,y2b)) : others) =+ if y2a == y1b+ then mergeAdjacent ((Sq b z xS (y1a,y2b)): others)+ else if y1a == y2b+ then mergeAdjacent ((Sq b z xS (y1b,y2a)): others)+ else pres : mergeAdjacent (next : others)+ mergeAdjacent a = a+ in+ mergeAdjacent orderedQuads joinXaligned [] = [] --joinYaligned (pres@(Sq b z (x1,x2) yS):sqs) = +joinYaligned quads@((Sq b z _ yS):_) = 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+ orderedQuads = sortBy + (\(Sq _ _ (xa,_) _) (Sq _ _ (xb,_) _) -> compare xa xb)+ quads+ mergeAdjacent (pres@(Sq _ _ (x1a,x2a) _) : next@(Sq _ _ (x1b,x2b) _) : others) =+ if x2a == x1b+ then mergeAdjacent ((Sq b z (x1a,x2b) yS): others)+ else if x1a == x2b+ then mergeAdjacent ((Sq b z (x1b,x2a) yS): others)+ else pres : mergeAdjacent (next : others)+ mergeAdjacent a = a+ in+ mergeAdjacent orderedQuads joinYaligned [] = [] +-- Reconstruct a triangle squareToTri (Sq (b1,b2,b3) z (x1,x2) (y1,y2)) = let- zV = b3 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+ zV = b3 ^* z+ (x1V, x2V) = (x1 *^ b1, x2 *^ b1)+ (y1V, y2V) = (y1 *^ b2, y2 *^ b2)+ a = zV ^+^ x1V ^+^ y1V+ b = zV ^+^ x2V ^+^ y1V+ c = zV ^+^ x1V ^+^ y2V+ d = zV ^+^ x2V ^+^ y2V in [(a,b,c),(c,b,d)]
Graphics/Implicit/Export/Render/Interpolate.hs view
@@ -3,51 +3,166 @@ module Graphics.Implicit.Export.Render.Interpolate (interpolate) where +import Graphics.Implicit.Definitions++-- Consider a function f(x):++{-+ | \ f(x)+ | - \+ |_______\________ x+ |+ \+-}++-- The purpose of interpolate is to find the value of x where f(x) crosses zero.+-- This should be accomplished cheaply and accuratly.++-- We are given the constraint that x will be between a and b.++-- We are also given the values of f at a and b: aval and bval.++-- Additionaly, we get f (continuous and differentiable almost everywhere),+-- and the resolution of the object (so that we can make decisions about +-- how precise we need to be).++-- While the output will never be used, interpolate will be called+-- in cases where f(x) doesn't cross zero (ie. aval and bval are both+-- positive or negative.++-- Clarification: If f(x) crosses zero, but doesn't necessarily have+-- to do so by intermediate value theorem, it is beyond the scope of this+-- function.++-- If it doesn't cross zero, we don't actually care what answer we give,+-- just that it's cheap.++interpolate :: ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ -> ℝ interpolate (a,aval) (b,bval) _ _ | aval*bval > 0 = a-interpolate (a,aval) (b,bval) f res = ++-- The obvious:++-- The obvious:+interpolate (a, 0) _ _ _ = a+interpolate _ (b, 0) _ _ = b++-- It may seem, at first, that our task is trivial.+-- Just use linear interpolation!+-- Unfortunatly, there's a nasty failure case++{- /+ /+ ________#________/____+ ________________/+-}++-- This is really common for us, for example in cubes,+-- where another variable dominates.++-- It may even be the case that, because we are so close+-- to the side, it looks like we are really close to an+-- answer... And we just give it back.++-- So we need to detect this. And get free goodies while we're+-- at it (shrink domain to guess within fromm (a,b) to (a',b'))+-- :)++{-interpolate (a,aval) (b,bval) f res = let+ -- a' and b' are just a and b shifted inwards slightly. a' = (a*95+5*b)/100 b' = (b*95+5*a)/100+ -- we evaluate at them. a'val = f a' b'val = f b'+ -- ... so we can calculate the derivatives! deriva = abs $ 20*(aval - a'val) derivb = abs $ 20*(bval - b'val)- 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+ -- And if one side of the function is slow...+ in if abs deriva < 0.1 || abs derivb < 0.1+ -- We use a binary search interpolation!+ then+ -- The best case is that it crosses between a and a'+ if aval*a'val < 0+ then+ interpolate_bin 0 (a,aval) (a',a'val) f+ -- Or between b' and b+ else if bval*b'val < 0+ then interpolate_bin 0 (b',b'val) (b,bval) f+ -- But in the worst case, we get to shrink to (a',b') :)+ else interpolate_bin 0 (a',a'val) (b',b'val) f+ -- Otherwise, we use our friend, linear interpolation!+ else+ -- again...+ -- The best case is that it crosses between a and a'+ if aval*a'val < 0+ then+ interpolate_lin 0 (a,aval) (a',a'val) f+ -- Or between b' and b+ else if bval*b'val < 0+ then interpolate_lin 0 (b',b'val) (b,bval) f+ -- But in the worst case, we get to shrink to (a',b') :)+ else interpolate_lin 0 (a',a'val) (b',b'val) f+-} -interpolate_lin _ (a, 0) _ _ _ = a-interpolate_lin _ _ (b, 0) _ _ = b-interpolate_lin n (a, aval) (b, bval) obj res | aval /= bval= +interpolate (a,aval) (b,bval) f res =+ -- Make sure aval > bval, then pass to interpolate_bin+ if aval > bval+ then interpolate_lin 0 (a,aval) (b,bval) f+ else interpolate_lin 0 (b,bval) (a,aval) f++-- Yay, linear interpolation!++-- Try the answer linear interpolation gives us...+-- (n is to cut us off if recursion goes too deep)++interpolate_lin n (a, aval) (b, bval) obj | aval /= bval= let+ -- Interpolate and evaluate mid = a + (b-a)*aval/(aval-bval) midval = obj mid- in if abs midval < res/500 || mid > 3+ -- Are we done?+ in if midval == 0 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+ -- + else let+ (a', a'val, b', b'val, improveRatio) = + if midval > 0+ then (mid, midval, b, bval, midval/aval)+ else (a, aval, mid, midval, midval/bval) -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+ -- some times linear interpolate doesn't work,+ -- because one side is very close to zero and flat+ -- we catch it because the interval won't shrink when+ -- this is the case. To test this, we look at whether+ -- the replaced point evaluates to substantially closer+ -- to zero than the previous one.+ in if improveRatio < 0.3 && n < 4+ -- And we continue on.+ then interpolate_lin (n+1) (a', a'val) (b', b'val) obj+ -- But if not, we switch to binary interpolate, which is + -- immune to this problem+ else interpolate_bin (n+1) (a', a'val) (b', b'val) obj -interpolate_bin' 4 (a,aval) (b,bval) f = +-- And a fallback:+interpolate_lin _ (a, _) _ _ = a++-- Now for binary searching!++-- The termination case:++interpolate_bin 5 (a,aval) (b,bval) f = if abs aval < abs bval then a else b-interpolate_bin' n (a,aval) (b,bval) f =++-- Otherwise, have fun with mid!++interpolate_bin n (a,aval) (b,bval) f = let mid = (a+b)/2 midval = f mid in if midval > 0- then interpolate_bin' (n+1) (mid,midval) (b,bval) f- else interpolate_bin' (n+1) (a,aval) (mid,midval) f+ 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
@@ -3,48 +3,58 @@ module Graphics.Implicit.Export.Render.RefineSegs where +import Data.VectorSpace import Graphics.Implicit.Definitions-import qualified Graphics.Implicit.SaneOperators as S-import Graphics.Implicit.SaneOperators ((⋅), (⨯), norm, normalized)+import Graphics.Implicit.Export.Util (centroid) +-- The purpose of refine is to add detail to a polyline aproximating+-- the boundary of an implicit function and to remove redundant points.+ refine :: ℝ -> Obj2 -> [ℝ2] -> [ℝ2]++-- We break this into two steps: detail and then simplify.+ refine res obj = simplify res . detail' res obj +-- we wrap detail to make it ignore very small segments, and to pass in +-- an initial value for a pointer counter argument. This is detail' + 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 adds new points to a polyline to add more detail.+ detail :: Int -> ℝ -> (ℝ2 -> ℝ) -> [ℝ2] -> [ℝ2]-detail n res obj [p1@(x1,y1), p2@(x2,y2)] | n < 2 =+detail n res obj [p1, p2] | n < 2 = let- mid@(midX, midY) = (p1 S.+ p2) S./ (2 :: ℝ)+ mid = centroid [p1,p2] midval = obj mid in if abs midval < res / 40- then [(x1,y1), (x2,y2)]+ then [p1, p2] 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+ normal = (\(a,b) -> (b, -a)) $ normalized (p2 ^-^ p1) + derivN = -(obj (mid ^-^ (normal ^* (midval/2))) - midval) * (2/midval)+ in if abs derivN > 0.5 && abs derivN < 2 && abs (midval/derivN) < 3*res then let- mid' = mid S.- (normal S.* (midval / derivN))- in detail (n+1) res obj [(x1,y1), mid'] - ++ tail (detail (n+1) res obj [mid', (x2,y2)] )+ mid' = mid ^-^ (normal ^* (midval / derivN))+ in detail (n+1) res obj [p1, mid'] + ++ tail (detail (n+1) res obj [mid', p2] ) else let- derivX = (obj (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+ derivX = (obj (mid ^+^ (res/100, 0)) - midval)*100/res+ derivY = (obj (mid ^+^ (0, res/100)) - midval)*100/res+ derivNormSq = derivX^2 + derivY^2+ in if abs derivNormSq > 0.09 && abs derivNormSq < 4 && abs (midval/sqrt derivNormSq) < 3*res then let (dX, dY) = (- derivX*midval/derivNormSq, - derivY*midval/derivNormSq)- mid'@(midX', midY') = - (midX + dX, midY + dY)+ mid' = mid ^+^ (dX, dY) midval' = obj mid' posRatio = midval/(midval - midval')- mid''@(midX'', midY'') = (midX + dX*posRatio, midY + dY*posRatio)+ mid'' = mid ^+^ (dX*posRatio, 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 (n+1) res obj [p1, mid''] ++ tail (detail (n+1) res obj [mid'', p2] )+ else [p1, p2] detail _ _ _ x = x@@ -53,7 +63,7 @@ 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+ if abs ( ((b ^-^ a) ⋅ (c ^-^ a)) - magnitude (b ^-^ a) * magnitude (c ^-^ a) ) < 0.0001 then simplify1 (a:c:xs) else a : simplify1 (b:c:xs) simplify1 a = a@@ -61,8 +71,8 @@ {- simplify2 :: ℝ -> [ℝ2] -> [ℝ2] simplify2 res [a,b,c,d] = - if norm (b S.- c) < res/10- then [a, ((b S.+ c) S./ (2::ℝ)), d]+ if norm (b - c) < res/10+ then [a, ((b + c) / (2::ℝ)), d] else [a,b,c,d] simplify2 _ a = a
Graphics/Implicit/Export/Render/TesselateLoops.hs view
@@ -5,9 +5,9 @@ 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+import Graphics.Implicit.Export.Util (centroid)+import Data.VectorSpace+import Data.Cross tesselateLoop :: ℝ -> Obj3 -> [[ℝ3]] -> [TriSquare] @@ -15,6 +15,15 @@ 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)]@@ -25,16 +34,30 @@ [[[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) =+{-+ #__#+ | | -> if parallegram then quad+ #__#+-}+{- We're going to disable quads for now.+tesselateLoop res obj [[a,_],[b,_],[c,_],[d,_]] | centroid [a,c] == centroid [b,d] = let- b1 = normalized $ a S.- b- b2 = normalized $ c S.- b- b3 = b1 ⨯ b2+ b1 = normalized $ a ^-^ b+ b2 = normalized $ c ^-^ b+ b3 = b1 `cross3` b2 in [Sq (b1,b2,b3) (a ⋅ b3) (a ⋅ b1, c ⋅ b1) (a ⋅ b2, c ⋅ b2) ]+-}+{-+ #__# #__#+ | | -> | /|+ #__# #/_#+-} -tesselateLoop res obj [[a,_],[b,_],[c,_],[d,_]] | obj ((a S.+ c) S./ (2 :: ℝ)) < res/30 =+tesselateLoop res obj [[a,_],[b,_],[c,_],[d,_]] | obj (centroid [a,c]) < res/30 = return $ Tris $ [(a,b,c),(a,c,d)] +-- Fallback case: make fans+ tesselateLoop res obj pathSides = return $ Tris $ let path' = concat $ map init pathSides@@ -42,17 +65,16 @@ in if null path then early_tris else let- len = fromIntegral $ length path :: ℝ- mid@(midx,midy,midz) = (foldl1 (S.+) path) S./ len+ mid@(midx,midy,midz) = centroid path 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)+ preNormal = foldl1 (^+^) $+ [ a `cross3` b | (a,b) <- zip path (tail path ++ [head path]) ]+ preNormalNorm = magnitude preNormal+ normal = preNormal ^/ preNormalNorm+ deriv = (obj (mid ^+^ (normal ^* (res/100)) ) ^-^ midval)/res*100+ mid' = mid ^-^ normal ^* (midval/deriv) in if abs midval > res/50 && preNormalNorm > 0.5 && abs deriv > 0.5 - && abs (deriv*midval) < 1.1*res && 5*abs (obj mid') < abs midval+ && abs (midval/deriv) < 2*res && 3*abs (obj mid') < abs midval then early_tris ++ [(a,b,mid') | (a,b) <- zip path (tail path ++ [head path]) ] else early_tris ++ [(a,b,mid) | (a,b) <- zip path (tail path ++ [head path]) ] @@ -60,14 +82,14 @@ 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+ if abs (obj $ centroid [a,b,c]) < res/50 then ( [(a,b,c)], []) else ([], path) shrinkLoop n path@(a:b:c:xs) res obj | n < length path =- if abs (obj ((a S.+ c) S./ (2::ℝ) )) < res/50+ if abs (obj (centroid [a,c])) < res/50 then let (tris,remainder) = shrinkLoop 0 (a:c:xs) res obj in ((a,b,c):tris, remainder)
Graphics/Implicit/Export/Symbolic/Rebound2.hs view
@@ -1,12 +1,12 @@ module Graphics.Implicit.Export.Symbolic.Rebound2 (rebound2) where +import Data.VectorSpace import Graphics.Implicit.Definitions-import qualified Graphics.Implicit.SaneOperators as S rebound2 :: BoxedObj2 -> BoxedObj2 rebound2 (obj, (a,b)) = let d :: ℝ2- d = (b S.- a) S./ (10.0 :: ℝ)+ d = (b ^-^ a) ^/ 10 in - (obj, ((a S.- d), (b S.+ d)))+ (obj, ((a ^-^ d), (b ^+^ d)))
Graphics/Implicit/Export/Symbolic/Rebound3.hs view
@@ -1,13 +1,13 @@ module Graphics.Implicit.Export.Symbolic.Rebound3 (rebound3) where import Graphics.Implicit.Definitions-import qualified Graphics.Implicit.SaneOperators as S+import Data.VectorSpace rebound3 :: BoxedObj3 -> BoxedObj3 rebound3 (obj, (a,b)) = let d :: ℝ3- d = (b S.- a) S./ (10.0 :: ℝ)+ d = (b ^-^ a) ^/ 10 in - (obj, ((a S.- d), (b S.+ d)))+ (obj, ((a ^-^ d), (b ^+^ d)))
Graphics/Implicit/Export/SymbolicFormats.hs view
@@ -1,81 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}+ -- 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+import Graphics.Implicit.Export.TextBuilderUtils -scad3 :: ℝ -> SymbolicObj3 -> String+import Control.Monad.Reader+import Control.Monad (sequence) -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+import Data.List (intersperse) -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)- ++ "]"- ++ ");" +scad2 :: ℝ -> SymbolicObj2 -> Text +scad2 res obj = toLazyText $ runReader (buildS2 obj) res++scad3 :: ℝ -> SymbolicObj3 -> Text +scad3 res obj = toLazyText $ runReader (buildS3 obj) res++++-- Format an openscad call given that all the modified objects are in the Reader monad...++call :: Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder+call name args [] = return $ name <> buildArgs args <> ";"+call name args [obj] = fmap ((name <> buildArgs args) <>) obj+call name args objs = do+ objs' <- fmap (mconcat . map (<> "\n")) $ sequence objs+ return $! name <> buildArgs args <> "{\n" <> objs' <> "}\n"++buildArgs [] = "()"+buildArgs args = "([" <> mconcat (intersperse "," args) <> "])"+++buildS3 :: SymbolicObj3 -> Reader ℝ Builder++buildS3 (UnionR3 0 objs) = call "union" [] $ map buildS3 objs++buildS3 (DifferenceR3 0 objs) = call "difference" [] $ map buildS3 objs++buildS3 (IntersectR3 0 objs) = call " intersection" [] $ map buildS3 objs++buildS3 (Translate3 (x,y,z) obj) = call "translate" [bf x, bf y, bf z] [buildS3 obj]++buildS3 (Scale3 (x,y,z) obj) = call "scale" [bf x, bf y, bf x] [buildS3 obj]++buildS3 (Rect3R 0 (x1,y1,z1) (x2,y2,z2)) = call "translate" [bf x1, bf y1, bf z1] [+ call "cube" [bf $ x2 - x1, bf $ y2 - y1, bf $ z2 - z1] []+ ]+buildS3 (Cylinder h r1 r2) = call "cylinder" [+ "r1 = " <> bf r1+ ,"r2 = " <> bf r2+ , bf h+ ] []++buildS3 (Sphere r) = call "sphere" ["r = " <> bf r] []++buildS3 (ExtrudeR 0 obj h) = call "linear_extrude" [bf h] [buildS2 obj]++buildS3 (ExtrudeRotateR 0 twist obj h) =+ call "linear_extrude" [bf h, "twist = " <> bf twist] [buildS2 obj]++buildS3 (ExtrudeRM 0 (Just twist) Nothing Nothing obj (Left height)) = do+ res <- ask+ call "union" [] [+ call "rotate" ["0","0", bf $ twist h] [+ call "linear_extrude" [bf res, "twist = " <> bf (twist (h+res) - twist h)][+ buildS2 obj+ ] + ] | h <- init [0, res .. height]+ ]++buildS2 :: SymbolicObj2 -> Reader ℝ Builder++buildS2 (UnionR2 0 objs) = call "union" [] $ map buildS2 objs++buildS2 (DifferenceR2 0 objs) = call "difference" [] $ map buildS2 objs++buildS2 (IntersectR2 0 objs) = call "intersection" [] $ map buildS2 objs++buildS2 (Translate2 (x,y) obj) = call "translate" [bf x, bf y] $ [buildS2 obj]++buildS2 (Scale2 (x,y) obj) = call "scale" [bf x, bf y] $ [buildS2 obj]++buildS2 (RectR 0 (x1,y1) (x2,y2)) = call "translate" [bf x1, bf y1] [+ call "cube" [bf $ x2 - x1, bf $ y2 - y1] []+ ]++buildS2 (Circle r) = call "circle" [bf r] []++buildS2 (PolygonR 0 points) = call "polygon" [buildVector [x,y] | (x,y) <- points] []+ where buildVector comps = "[" <> mconcat (intersperse "," $ map bf comps) <> "]"
Graphics/Implicit/Export/SymbolicObj2.hs view
@@ -20,8 +20,9 @@ import Graphics.Implicit.Export.Symbolic.Rebound2 import Graphics.Implicit.Export.Symbolic.Rebound3 --import qualified Graphics.Implicit.SaneOperators as S+import qualified Graphics.Implicit.Export.Render as Render (getContour)+ +import Data.VectorSpace instance DiscreteAproxable SymbolicObj2 [Polyline] where discreteAprox res obj = symbolicGetContour res obj@@ -33,9 +34,9 @@ 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+ v = (\(a,b) -> (b, -a)) (y - x)+ dv = v ^/ (magnitude v / res / 0.1)+ in if obj (x + dv) - obj x > 0 then points else reverse points @@ -43,17 +44,18 @@ 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 (Translate2 v obj) = map (map (+ v) ) $ symbolicGetContour res obj+symbolicGetContour res (Scale2 s@(a,b) obj) = map (map (⋯* s)) $ symbolicGetContour (res/sc) obj+ where sc = max a b symbolicGetContour res obj = case rebound2 (getImplicit2 obj, getBox2 obj) of- (obj, (a,b)) -> getContour a b (res,res) obj+ (obj, (a,b)) -> Render.getContour a b res obj symbolicGetContourMesh :: ℝ -> SymbolicObj2 -> [(ℝ2,ℝ2,ℝ2)]-symbolicGetContourMesh res (Translate2 v obj) = map (\(a,b,c) -> (a 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 (Translate2 v obj) = map (\(a,b,c) -> (a + v, b + v, c + v) ) $ symbolicGetContourMesh res obj+symbolicGetContourMesh res (Scale2 s@(a,b) obj) = map (\(a,b,c) -> (a ⋯* s, b ⋯* s, c ⋯* s) ) $+ symbolicGetContourMesh (res/sc) obj where sc = max a b symbolicGetContourMesh _ (RectR 0 (x1,y1) (x2,y2)) = [((x1,y1), (x2,y1), (x2,y2)), ((x2,y2), (x1,y2), (x1,y1)) ] symbolicGetContourMesh res (Circle r) = [ ((0,0),
Graphics/Implicit/Export/SymbolicObj3.hs view
@@ -20,14 +20,13 @@ import Graphics.Implicit.Export.SymbolicObj2 -import qualified Graphics.Implicit.SaneOperators as S- 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 (normTriangle)+import Data.VectorSpace instance DiscreteAproxable SymbolicObj3 TriangleMesh where@@ -38,10 +37,9 @@ 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)+ map (\(a,b,c) -> (a ^+^ v, b ^+^ v, c ^+^ v) ) (symbolicGetMesh res obj) -- A scaled objects mesh is its mesh scaled symbolicGetMesh res (Scale3 s obj) =@@ -49,7 +47,7 @@ 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 ⋯* a, s ⋯* b, s ⋯* c) in map scaleTriangle mesh -- A couple triangles make a cube...@@ -135,7 +133,7 @@ side_tris ++ bottom_tris ++ top_tris -symbolicGetMesh res (ExtrudeRM r twist scale translate obj2 h) = +symbolicGetMesh res (ExtrudeRM r@0 twist scale translate obj2 h@(Left _)) = let -- Get a Obj2 (magnitude descriptor object) obj2mag :: Obj2 -- = ℝ2 -> ℝ@@ -208,7 +206,6 @@ in map transformTriangle (side_tris ++ bottom_tris ++ top_tris)--} symbolicGetMesh res inputObj@(UnionR3 r objs) = let
+ Graphics/Implicit/Export/TextBuilderUtils.hs view
@@ -0,0 +1,57 @@+-- This module exists to re-export a coherent set of functions to define+-- Data.Text.Lazy builders with.+++module Graphics.Implicit.Export.TextBuilderUtils + (+ -- Values from Data.Text.Lazy+ Text+ ,pack+ -- Values from Data.Text.Lazy.Builder, as well as some special builders+ ,Builder+ ,toLazyText+ ,fromLazyText+ ,buildInt+ -- Serialize a float in full precision+ ,bf+ -- Serialize a float with four decimal places+ ,buildTruncFloat+ -- Values from Data.Monoid+ ,(<>)+ ,Monoid.mconcat+ ,Monoid.mempty+ + ) where+import Data.Text.Lazy+-- We manually redefine this operator to avoid a dependency on base >= 4.5+-- This will become unnecessary later.+import qualified Data.Monoid as Monoid++import Data.Text.Lazy+import Data.Text.Lazy.Internal (defaultChunkSize)+import Data.Text.Lazy.Builder hiding (toLazyText)+import Data.Text.Lazy.Builder.RealFloat+import Data.Text.Lazy.Builder.Int++import Graphics.Implicit.Definitions++-- The chunk size for toLazyText is very small (128 bytes), so we export+-- a version with a much larger size (~16 K)+toLazyText :: Builder -> Text+toLazyText = toLazyTextWith defaultChunkSize++bf, buildTruncFloat :: ℝ -> Builder++bf = formatRealFloat Exponent Nothing+{-# INLINE bf #-}++buildTruncFloat = formatRealFloat Fixed $ Just 4++buildInt :: Int -> Builder+buildInt = decimal++-- This is directly copied from base 4.5.1.0+infixr 6 <>+(<>) :: Monoid.Monoid m => m -> m -> m+(<>) = Monoid.mappend+{-# INLINE (<>) #-}
Graphics/Implicit/Export/TriangleMeshFormats.hs view
@@ -1,65 +1,91 @@+{-# LANGUAGE OverloadedStrings #-}+ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU GPL, see LICENSE module Graphics.Implicit.Export.TriangleMeshFormats where import Graphics.Implicit.Definitions+import Graphics.Implicit.Export.TextBuilderUtils -stl triangles = text- where- stlHeader = "solid ImplictCADExport\n"- stlFooter = "endsolid ImplictCADExport\n"- vertex :: ℝ3 -> String- vertex (x,y,z) = "vertex " ++ show x ++ " " ++ show y ++ " " ++ show z- stlTriangle :: (ℝ3, ℝ3, ℝ3) -> String- stlTriangle (a,b,c) =- "facet normal 0 0 0\n"- ++ "outer loop\n"- ++ vertex a ++ "\n"- ++ vertex b ++ "\n"- ++ vertex c ++ "\n"- ++ "endloop\n"- ++ "endfacet\n"- text = stlHeader- ++ (concat $ map stlTriangle triangles)- ++ stlFooter+import Blaze.ByteString.Builder hiding (Builder)+import Blaze.ByteString.Builder.ByteString+import Data.ByteString (replicate)+import Data.ByteString.Lazy (ByteString)+import Data.Storable.Endian +import Prelude hiding (replicate)+import Data.VectorSpace+import Data.Cross hiding (normal) -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+normal :: (ℝ3,ℝ3,ℝ3) -> ℝ3+normal (a,b,c) =+ normalized $ (b + negateV a) `cross3` (c + negateV a) +stl triangles = toLazyText $ stlHeader <> mconcat (map triangle triangles) <> stlFooter+ where+ stlHeader = "solid ImplictCADExport\n"+ stlFooter = "endsolid ImplictCADExport\n"+ vector :: ℝ3 -> Builder+ vector (x,y,z) = bf x <> " " <> bf y <> " " <> bf z+ vertex :: ℝ3 -> Builder+ vertex v = "vertex " <> vector v+ triangle :: (ℝ3, ℝ3, ℝ3) -> Builder+ triangle (a,b,c) =+ "facet normal " <> vector (normal (a,b,c)) <> "\n"+ <> "outer loop\n"+ <> vertex a <> "\n"+ <> vertex b <> "\n"+ <> vertex c+ <> "\nendloop\nendfacet\n"+++-- Write a 32-bit little-endian float to a buffer.+float32LE :: Float -> Write+float32LE = writeStorable . LE++binaryStl :: [Triangle] -> ByteString+binaryStl triangles = toLazyByteString $ header <> lengthField <> mconcat (map triangle triangles)+ where header = fromByteString $ replicate 80 0+ lengthField = fromWord32le $ toEnum $ length triangles+ triangle (a,b,c) = normalV (a,b,c) <> point a <> point b <> point c <> fromWord16le 0+ point (x,y,z) = fromWrite $ float32LE x <> float32LE y <> float32LE z+ normalV ps = let (x,y,z) = normal ps+ in fromWrite $ float32LE x <> float32LE y <> float32LE z++jsTHREE :: TriangleMesh -> Text+jsTHREE triangles = toLazyText $ header <> vertcode <> facecode <> footer+ where+ -- some dense JS. Let's make helper functions so that we don't repeat code each line+ header = mconcat [+ "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 = mconcat [+ "}\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 -> Builder+ v (x,y,z) = "v(" <> bf x <> "," <> bf y <> "," <> bf z <> ");\n"+ -- A face line+ f :: Int -> Int -> Int -> Builder+ f posa posb posc = + "f(" <> buildInt posa <> "," <> buildInt posb <> "," <> buildInt 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 = mconcat $ map v verts+ facecode = mconcat $ do+ (n,_) <- zip [0, 3 ..] triangles+ let+ (posa, posb, posc) = (n, n+1, n+2)+ return $ f posa posb posc
Graphics/Implicit/Export/Util.hs view
@@ -7,22 +7,21 @@ module Graphics.Implicit.Export.Util {-(divideMesh2To, divideMeshTo, dividePolylineTo)-} where -import Prelude hiding ((+),(-),(*),(/)) import Graphics.Implicit.Definitions-import Graphics.Implicit.SaneOperators+import Data.VectorSpace 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 :: ℝ)+ 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) = +normVertex res obj p = let -- D_vf(p) = ( f(p) - f(p+v) ) /|v| -- but we'll actually scale v by res, so then |v| = res@@ -30,13 +29,17 @@ -- 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::ℝ))+ 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)+ in (p, normalized (dx,dy,dz))++centroid :: (VectorSpace v, Fractional (Scalar v)) => [v] -> v+centroid pts =+ (norm *^) $ foldl (^+^) zeroV pts+ where norm = recip $ realToFrac $ length pts+{-# INLINE centroid #-} {--- If we need to make a 2D mesh finer... divideMesh2To :: ℝ -> [(ℝ2, ℝ2, ℝ2)] -> [(ℝ2, ℝ2, ℝ2)]
Graphics/Implicit/ExtOpenScad.hs view
@@ -3,22 +3,39 @@ -- We'd like to parse openscad code, with some improvements, for backwards compatability. -module Graphics.Implicit.ExtOpenScad (runOpenscad, OpenscadObj (..) ) where+module Graphics.Implicit.ExtOpenScad (runOpenscad, OVal (..) ) where -import Graphics.Implicit.ExtOpenScad.Definitions (OpenscadObj (..) )+import Graphics.Implicit.Definitions+import Graphics.Implicit.ExtOpenScad.Definitions+import Graphics.Implicit.ExtOpenScad.Parser.Statement+import Graphics.Implicit.ExtOpenScad.Eval.Statement import Graphics.Implicit.ExtOpenScad.Default (defaultObjects)-import Graphics.Implicit.ExtOpenScad.Statements (computationStatement)-import Graphics.Implicit.ExtOpenScad.Util.Computation (runComputations)+import Graphics.Implicit.ExtOpenScad.Util.OVal -import Text.ParserCombinators.Parsec (parse, many1, many, space, eof)-import Control.Monad (liftM)+import qualified Data.Maybe as Maybe+import qualified Data.List as List+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Control.Monad as Monad+import qualified Control.Monad.State as State+import Control.Monad.State (State,StateT, get, put, modify, liftIO)+import qualified System.Directory as Dir -- Small wrapper to handle parse errors, etc-runOpenscad str = case parse (do {s <- many1 computationStatement; many space; eof; return s}) "" str of- Right res -> Right $ runComputationsDefault res- Left err -> Left err+runOpenscad s =+ let+ initial = defaultObjects+ rearrange (_, (varlookup, ovals, _ , _ , _)) = (varlookup, obj2s, obj3s) where+ (obj2s, obj3s, others) = divideObjs ovals+ in case parseProgram "" s of+ Left e -> Left e+ Right sts -> Right+ $ fmap rearrange+ $ (\sts -> do+ path <- Dir.getCurrentDirectory+ State.runStateT sts (initial, [], path, (), () )+ )+ $ Monad.mapM_ runStatementI sts -runComputationsDefault = runComputations $- return (defaultObjects, [], [])
Graphics/Implicit/ExtOpenScad/Default.hs view
@@ -7,16 +7,18 @@ import Graphics.Implicit.Definitions import Graphics.Implicit.ExtOpenScad.Definitions+import Graphics.Implicit.ExtOpenScad.Util.OVal import Graphics.Implicit.ExtOpenScad.Primitives import Data.Map (Map, fromList) -defaultObjects :: VariableLookup -- = Map String OpenscadObj+defaultObjects :: VarLookup -- = Map String OVal defaultObjects = fromList $ defaultConstants ++ defaultFunctions ++ defaultFunctions2 ++ defaultFunctionsSpecial ++ defaultModules+ ++ defaultPolymorphicFunctions -- Missing standard ones: -- rand, lookup, @@ -32,6 +34,9 @@ ("asin", asin), ("acos", acos), ("atan", atan),+ ("sinh", sinh),+ ("cosh", cosh),+ ("tanh", tanh), ("abs", abs), ("sign", signum), ("floor", fromIntegral . floor ),@@ -55,7 +60,7 @@ defaultFunctionsSpecial = [ ("map", toOObj $ flip $ - (map :: (OpenscadObj -> OpenscadObj) -> [OpenscadObj] -> [OpenscadObj] ) + (map :: (OVal -> OVal) -> [OVal] -> [OVal] ) ) ]@@ -63,5 +68,156 @@ defaultModules = map (\(a,b) -> (a, OModule b)) primitives++++-- more complicated ones:++defaultPolymorphicFunctions = + [ + ("+", sum),+ ("sum", sum),+ ("*", prod),+ ("prod", prod),+ ("/", div),+ ("-", toOObj sub), + ("^", toOObj ((**) :: ℝ -> ℝ -> ℝ)), + ("negate", toOObj negate),+ ("index", toOObj index),+ ("splice", toOObj osplice),+ ("<", toOObj ((<) :: ℝ -> ℝ -> Bool) ),+ (">", toOObj ((>) :: ℝ -> ℝ -> Bool) ),+ (">=", toOObj ((>=) :: ℝ -> ℝ -> Bool) ),+ ("<=", toOObj ((<=) :: ℝ -> ℝ -> Bool) ),+ ("==", toOObj ((==) :: OVal -> OVal -> Bool) ),+ ("!=", toOObj ((/=) :: OVal -> OVal -> Bool) ),+ ("?", toOObj ( ternary :: Bool -> OVal -> OVal -> OVal) ),+ ("&&", toOObj (&&) ),+ ("||", toOObj (||) ),+ ("!", toOObj not ),+ ("list_gen", toOObj list_gen),+ ("++", concat),+ ("len", toOObj olength),+ ("str", toOObj (show :: OVal -> String))+ ] where++ -- Some key functions are written as OVals in optimizations attempts++ prod = OFunc $ \x -> case x of+ (OList (x:xs)) -> foldl mult x xs+ (OList []) -> ONum 1+ a -> OError ["Product takes a list"]++ mult (ONum a) (ONum b) = ONum (a*b)+ mult (ONum a) (OList b) = OList (map (mult (ONum a)) b)+ mult (OList a) (ONum b) = OList (map (mult (ONum b)) a)+ mult a b = errorAsAppropriate "multiply" a b++ div = OFunc $ \x -> case x of+ (ONum a) -> OFunc $ \y -> case y of+ (ONum b) -> ONum (a/b)+ b -> errorAsAppropriate "divide" (ONum a) b+ a -> OFunc $ \y -> case y of+ b -> div' a b++ div' (ONum a) (ONum b) = ONum (a/b)+ div' (OList a) (ONum b) = OList (map (\x -> div' x (ONum b)) a)+ div' a b = errorAsAppropriate "divide" a b++ omod (ONum a) (ONum b) = ONum $ fromIntegral $ mod (floor a) (floor b)+ omod a b = errorAsAppropriate "modulo" a b++ append (OList a) (OList b) = OList $ a++b+ append (OString a) (OString b) = OString $ a++b+ append a b = errorAsAppropriate "append" a b++ concat = OFunc $ \x -> case x of+ (OList (x:xs)) -> foldl append x xs+ (OList []) -> OList []+ _ -> OError ["concat takes a list"]++ sum = OFunc $ \x -> case x of+ (OList (x:xs)) -> foldl add x xs+ (OList []) -> ONum 0+ a -> OError ["Product takes a list"]++ add (ONum a) (ONum b) = ONum (a+b)+ add (OList a) (OList b) = OList $ zipWith add a b+ add a b = errorAsAppropriate "add" a b++ sub (ONum a) (ONum b) = ONum (a-b)+ sub (OList a) (OList b) = OList $ zipWith sub a b+ sub a b = errorAsAppropriate "subtract" a b++ negate (ONum n) = ONum (-n)+ negate (OList l) = OList $ map negate l+ negate a = OError ["Can't negate " ++ oTypeStr a ++ "(" ++ show a ++ ")"]++ {-numCompareToExprCompare :: (ℝ -> ℝ -> Bool) -> Oval -> OVal -> Bool+ numCompareToExprCompare f a b =+ case (fromOObj a :: Maybe ℝ, fromOObj b :: Maybe ℝ) of+ (Just a, Just b) -> f a b+ _ -> False-}++ index (OList l) (ONum ind) = + let n = floor ind + in if n < length l then l !! n else OError ["List accessd out of bounds"]+ index (OString s) (ONum ind) = + let n = floor ind + in if n < length s then OString [s !! n] else OError ["List accessd out of bounds"]+ index a b = errorAsAppropriate "index" a b++ osplice (OList list) (ONum a) ( ONum b ) = + OList $ splice list (floor a) (floor b)+ osplice (OString str) (ONum a) ( ONum b ) = + OString $ splice str (floor a) (floor b)+ osplice (OList list) (OUndefined) (ONum b ) = + OList $ splice list 0 (floor b)+ osplice (OString str) (OUndefined) (ONum b ) = + OString $ splice str 0 (floor b)+ osplice (OList list) (ONum a) ( OUndefined) = + OList $ splice list (floor a) (length list + 1)+ osplice (OString str) (ONum a) ( OUndefined) = + OString $ splice str (floor a) (length str + 1)+ osplice (OList list) (OUndefined) (OUndefined) = + OList $ splice list 0 (length list + 1)+ osplice (OString str) (OUndefined) (OUndefined) = + OString $ splice str 0 (length str + 1)+ osplice _ _ _ = OUndefined++ splice :: [a] -> Int -> Int -> [a]+ splice [] _ _ = []+ splice (l@(x:xs)) a b + | a < 0 = splice l (a+n) b+ | b < 0 = splice l a (b+n)+ | a > 0 = splice xs (a-1) (b-1)+ | b > 0 = x:(splice xs a (b-1) )+ | otherwise = []+ where n = length l++ errorAsAppropriate _ err@(OError _) _ = err+ errorAsAppropriate _ _ err@(OError _) = err+ errorAsAppropriate name a b = OError + ["Can't " ++ name ++ " objects of types " ++ oTypeStr a ++ " and " ++ oTypeStr b ++ "."]++ list_gen :: [ℝ] -> Maybe [ℝ]+ list_gen [a,b] = Just [fromIntegral (ceiling a).. fromIntegral (floor b)]+ list_gen [a, b, c] =+ let+ nr = (c-a)/b+ n = fromIntegral (floor nr)+ in if nr - n > 0+ then Just + [fromIntegral (ceiling a), fromIntegral (ceiling (a+b)).. fromIntegral (floor (c - b*(nr -n)))]+ else Just + [fromIntegral (ceiling a), fromIntegral (ceiling (a+b)).. fromIntegral (floor c)]+ list_gen _ = Nothing++ ternary True a b = a+ ternary False a b = b++ olegnth (OString s) = ONum $ fromIntegral $ length s+ olength (OList s) = ONum $ fromIntegral $ length s+ olength a = OError ["Can't take length of a " ++ oTypeStr a ++ "."]
Graphics/Implicit/ExtOpenScad/Definitions.hs view
@@ -1,131 +1,61 @@--- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)--- Released under the GNU GPL, see LICENSE---- We'd like to parse openscad code, with some improvements, for backwards compatability.--{-# 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+import qualified Control.Monad as Monad+import Control.Monad.State (State,StateT)+import qualified Data.List as List --- Lets make it easy to change the object types we're using :)+type Symbol = String --- | The 2D object type to be used in ExtOpenScad-type Obj2Type = SymbolicObj2--- | The 3D object type to be used in ExtOpenScad-type Obj3Type = SymbolicObj3+data Pattern = Name Symbol+ | ListP [Pattern]+ | Wild+ | Symbol :@ Pattern+ deriving Show --- | To look up OpenscadObj variables with a string name-type VariableLookup = Map String OpenscadObj+data Expr = Var Symbol+ | LitE OVal+ | ListE [Expr]+ | LamE [Pattern] Expr+ | Expr :$ [Expr]+ deriving Show +data StatementI = StatementI Int (Statement StatementI)+ deriving Show++data Statement st = Include String Bool+ | Pattern := Expr+ | Echo [Expr]+ | For Pattern Expr [st]+ | If Expr [st] [st]+ | NewModule Symbol [(Symbol, Maybe Expr)] [st]+ | ModuleCall Symbol [(Maybe Symbol, Expr)] [st]+ | DoNothing+ deriving Show+++ -- | Objects for our OpenSCAD-like language-data OpenscadObj = OUndefined +data OVal = OUndefined + | OError [String] | OBool Bool | ONum ℝ- | OList [OpenscadObj]+ | OList [OVal] | OString String- | OFunc ( OpenscadObj -> OpenscadObj ) - | OModule ([ComputationStateModifier] -> ArgParser ComputationStateModifier)- | OError [String]+ | OFunc (OVal -> OVal)+ | OModule ([OVal] -> ArgParser (IO [OVal]))+ | OObj3 SymbolicObj3+ | OObj2 SymbolicObj2 -instance Eq OpenscadObj where- (ONum a) == (ONum b) = a == b+instance Eq OVal where (OBool a) == (OBool b) = a == b- (OList a) == (OList b) = a == b+ (ONum a) == (ONum b) = a == b+ (OList a) == (OList b) = all id $ zipWith (==) a b (OString a) == (OString b) = a == b _ == _ = False --- | 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+instance Show OVal where show OUndefined = "Undefined" show (OBool b) = show b show (ONum n) = show n@@ -134,33 +64,35 @@ show (OFunc f) = "<function>" show (OModule _) = "module" show (OError msgs) = "Execution Error:\n" ++ foldl1 (\a b -> a ++ "\n" ++ b) msgs+ show (OObj2 obj) = "<obj2: " ++ show obj ++ ">"+ show (OObj3 obj) = "<obj3: " ++ show obj ++ ">" +type VarLookup = Map String OVal+type FStack = [OVal]++collector s [x] = x+collector s l = Var s :$ [ListE l]++----------------------------------------------------------------- -- | 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) + = AP String (Maybe OVal) String (OVal -> ArgParser a) -- | For returns: -- ArgParserTerminator (return value)- | ArgParserTerminator a + | APTerminator a -- | For failure: -- ArgParserFailIf (test) (error message) (child for if true)- | ArgParserFailIf Bool String (ArgParser a)+ | APFailIf Bool String (ArgParser a) -- An example, then next- | ArgParserExample String (ArgParser a)+ | APExample String (ArgParser a) -- A string to run as a test, then invariants for the results, then next- | ArgParserTest String [TestInvariant] (ArgParser a)+ | APTest String [TestInvariant] (ArgParser a)+ -- A branch where there are a number of possibilities for the parser underneath+ | APBranch [ArgParser a] deriving (Show) data TestInvariant = EulerCharacteristic Int deriving (Show) -type ComputationState = IO (VariableLookup, [Obj2Type], [Obj3Type])--type ComputationStateModifier = ComputationState -> ComputationState--coerceNum (ONum n) = n-coerceNum _ = sqrt (-1)--coerceBool (OBool b) = b-coerceBool _ = False
+ Graphics/Implicit/ExtOpenScad/Eval/Expr.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE ViewPatterns #-}++module Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, matchPat) where++import Graphics.Implicit.Definitions+import Graphics.Implicit.ExtOpenScad.Definitions+import Graphics.Implicit.ExtOpenScad.Util.OVal+import Graphics.Implicit.ExtOpenScad.Util.StateC++import qualified Data.Maybe as Maybe+import qualified Data.List as List+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Control.Monad as Monad+import qualified Control.Monad.State as State+import Control.Monad.State (State,StateT, get, put, modify, liftIO)+++patVars :: Pattern -> [String]+patVars (Name name) = [name]+patVars (ListP pats) = concat $ map patVars pats+patVars _ = []++patMatch :: Pattern -> OVal -> Maybe [OVal]+patMatch (Name _) val = Just [val]+patMatch (ListP pats) (OList vals) = do+ matches <- Monad.zipWithM patMatch pats vals+ return $ concat matches+patMatch Wild _ = Just []+patMatch _ _ = Nothing++matchPat :: Pattern -> OVal -> Maybe VarLookup+matchPat pat val = do+ let vars = patVars pat+ vals <- patMatch pat val+ return $ Map.fromList $ zip vars vals+++evalExpr :: Expr -> StateC OVal+evalExpr expr = do+ varlookup <- getVarLookup+ (valf, _) <- liftIO $ State.runStateT (evalExpr' expr) (varlookup, [])+ return $ valf []++++evalExpr' :: Expr -> StateT (VarLookup, [String]) IO ([OVal] -> OVal)++evalExpr' (Var name ) = do+ (varlookup, namestack) <- get+ return $+ case (Map.lookup name varlookup, List.findIndex (==name) namestack) of+ (_, Just pos) -> \s -> s !! pos+ (Just val, _) -> const val+ _ -> const $ OError ["Variable " ++ name ++ " not in scope" ] ++evalExpr' (LitE val ) = return $ const val++evalExpr' (ListE exprs) = do+ valFuncs <- Monad.mapM evalExpr' exprs+ return $ \s -> OList $ map ($s) valFuncs++evalExpr' (fexpr :$ argExprs) = do+ fValFunc <- evalExpr' fexpr+ argValFuncs <- Monad.mapM evalExpr' argExprs+ return $ \s -> app (fValFunc s) (map ($s) argValFuncs)+ where + app f l = case (getErrors f, getErrors $ OList l) of+ (Nothing, Nothing) -> app' f l where+ app' (OFunc f) (x:xs) = app (f x) xs+ app' a [] = a+ app' x _ = OError ["Can't apply arguments to " ++ oTypeStr x]+ (Just err, _ ) -> OError [err]+ (_, Just err) -> OError [err]++evalExpr' (LamE pats fexpr) = do+ fparts <- Monad.forM pats $ \pat -> do+ modify (\(vl, names) -> (vl, patVars pat ++ names))+ return $ \f xss -> OFunc $ \val -> case patMatch pat val of+ Just xs -> f (xs ++ xss)+ Nothing -> OError ["Pattern match failed"]+ fval <- evalExpr' fexpr+ return $ foldr ($) fval fparts+++--------------+++simplifyExpr ((simplifyExpr -> Var f) :$ args) = (Var f :$) $+ let+ split b l = (filter b l, filter (not.b) l)+ args' = map simplifyExpr args+ (numArgs, nonNumArgs) = split (\x -> case x of LitE (ONum n) -> True; _ -> False) args'+ numArgs' = map (\(LitE (ONum n)) -> n) numArgs+ in case f of+ "+" -> (LitE $ ONum $ sum numArgs'):nonNumArgs+ "*" -> (LitE $ ONum $ product numArgs'):nonNumArgs+ _ -> args'+simplifyExpr x = x
+ Graphics/Implicit/ExtOpenScad/Eval/Statement.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}++module Graphics.Implicit.ExtOpenScad.Eval.Statement where++import Graphics.Implicit.Definitions+import Graphics.Implicit.ExtOpenScad.Definitions+import Graphics.Implicit.ExtOpenScad.Util.OVal+import Graphics.Implicit.ExtOpenScad.Util.ArgParser+import Graphics.Implicit.ExtOpenScad.Util.StateC+import Graphics.Implicit.ExtOpenScad.Eval.Expr+import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram)+++import qualified Data.Maybe as Maybe+import qualified Data.List as List+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Control.Monad as Monad+import qualified Control.Monad.State as State+import Control.Monad.State (State,StateT, get, put, modify, liftIO)+import qualified System.FilePath as FilePath+++runStatementI :: StatementI -> StateC ()++runStatementI (StatementI lineN (pat := expr)) = do+ val <- evalExpr expr+ let posMatch = matchPat pat val+ case (getErrors val, posMatch) of+ (Just err, _ ) -> errorC lineN err+ (_, Just match) -> modifyVarLookup $ Map.union match+ (_, Nothing ) -> errorC lineN "pattern match failed in assignment"++runStatementI (StatementI lineN (Echo exprs)) = do+ let+ show2 (OString s) = s+ show2 x = show x+ vals <- mapM evalExpr exprs+ case getErrors (OList vals) of+ Nothing -> liftIO $ putStrLn $ concat $ map show2 vals+ Just err -> errorC lineN err++runStatementI (StatementI lineN (For pat expr loopContent)) = do+ val <- evalExpr expr+ case (getErrors val, val) of+ (Just err, _) -> errorC lineN err+ (_, OList vals) -> Monad.forM_ vals $ \v ->+ case matchPat pat v of+ Just match -> do+ modifyVarLookup $ Map.union match+ runSuite loopContent+ Nothing -> return ()+ _ -> return ()++runStatementI (StatementI lineN (If expr a b)) = do+ val <- evalExpr expr+ case (getErrors val, val) of+ (Just err, _ ) -> errorC lineN ("In conditional expression of if statement: " ++ err)+ (_, OBool True ) -> runSuite a+ (_, OBool False) -> runSuite b+ _ -> return ()++runStatementI (StatementI lineN (NewModule name argTemplate suite)) = do+ argTemplate' <- Monad.forM argTemplate $ \(name, defexpr) -> do+ defval <- mapMaybeM evalExpr defexpr + return (name, defval)+ (varlookup, _, path, _, _) <- get+ runStatementI $ StatementI lineN $ (Name name :=) $ LitE $ OModule $ \vals -> do + newNameVals <- Monad.forM argTemplate' $ \(name, maybeDef) -> do+ val <- case maybeDef of+ Just def -> argument name `defaultTo` def+ Nothing -> argument name+ return (name, val)+ let+ children = ONum $ fromIntegral $ length vals+ child = OModule $ \vals -> do+ n :: ℕ <- argument "n";+ return $ return $ return $ + if n <= length vals+ then vals !! n+ else OUndefined+ childBox = OFunc $ \n -> case fromOObj n :: Maybe ℕ of+ Just n | n < length vals -> case vals !! n of+ -- _ -> toOObj $ getBox3 obj3+ -- _ -> toOObj $ getBox2 obj2+ _ -> OUndefined+ _ -> OUndefined+ newNameVals' = newNameVals ++ [("children", children),("child", child), ("childBox", childBox)]+ varlookup' = Map.union (Map.fromList newNameVals) varlookup+ suiteVals = runSuiteCapture varlookup' path suite+ return suiteVals++runStatementI (StatementI lineN (ModuleCall name argsExpr suite)) = do+ maybeMod <- lookupVar name+ (varlookup, _, path, _, _) <- get+ childVals <- fmap reverse $ liftIO $ runSuiteCapture varlookup path suite+ argsVal <- Monad.forM argsExpr $ \(posName, expr) -> do+ val <- evalExpr expr+ return (posName, val)+ newVals <- case maybeMod of+ Just (OModule mod) -> liftIO ioNewVals where+ argparser = mod childVals+ ioNewVals = case fst $ argMap argsVal argparser of+ Just iovals -> iovals+ Nothing -> return []+ Just foo -> do+ case getErrors foo of+ Just err -> errorC lineN err+ Nothing -> errorC lineN $ "Object called not module!"+ return []+ Nothing -> do+ errorC lineN $ "Module " ++ name ++ " not in scope."+ return []+ pushVals newVals++runStatementI (StatementI lineN (Include name injectVals)) = do+ name' <- getRelPath name+ content <- liftIO $ readFile name'+ case parseProgram name content of+ Left e -> liftIO $ putStrLn $ "Error parsing " ++ name ++ ":" ++ show e+ Right sts -> withPathShiftedBy (FilePath.takeDirectory name) $ do+ vals <- getVals+ putVals []+ runSuite sts+ vals' <- getVals+ if injectVals then putVals (vals' ++ vals) else putVals vals++++runSuite :: [StatementI] -> StateC ()+runSuite stmts = Monad.mapM_ runStatementI stmts++runSuiteCapture :: VarLookup -> FilePath -> [StatementI] -> IO [OVal]+runSuiteCapture varlookup path suite = do+ (res, state) <- State.runStateT + (runSuite suite >> getVals)+ (varlookup, [], path, (), () )+ return res++++
− Graphics/Implicit/ExtOpenScad/Expressions.hs
@@ -1,285 +0,0 @@--- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)--- Released under the GNU GPL, see LICENSE---- We'd like to parse openscad code, with some improvements, for backwards compatability.--module Graphics.Implicit.ExtOpenScad.Expressions where---- We need lookup from Data.Map-import Prelude hiding (lookup)-import Data.Map (Map, lookup)-import Graphics.Implicit.Definitions-import Graphics.Implicit.ExtOpenScad.Definitions-import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Expr--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)-variable = fmap (\varstr -> \varlookup -> case lookup varstr varlookup of- Nothing -> OUndefined- Just a -> a )- variableSymb--literal :: GenParser Char st (VariableLookup -> OpenscadObj)-literal = - try ( (string "true" >> return (\map -> OBool True) )- <|> (string "false" >> return (\map -> OBool False) )- <?> "boolean" )- <|> try ( try (do- a <- (many1 digit);- char '.';- b <- (many digit);- return ( \map -> ONum ( read (a ++ "." ++ b) :: ℝ) );- ) <|> (do- a <- (many1 digit);- return ( \map -> ONum ( read a :: ℝ) );- ) <?> "number" )- <|> try ( ( do- string "\"";- strlit <- many $ try (string "\\\"" >> return '\"') <|> try (string "\\n" >> return '\n') <|> ( noneOf "\"\n");- string "\"";- return $ \map -> OString $ strlit;- ) <?> "string" )- <?> "literal"---- We represent the priority or 'fixity' of different types of expressions--- by the Int argument--expression :: Int -> GenParser Char st (VariableLookup -> OpenscadObj)-expression 10 = (try literal) <|> (try variable )- <|> ((do -- ( 1 + 5 )- string "(";- expr <- expression 0;- string ")";- return expr;- ) <?> "bracketed expression" )- <|> ( try ( do -- [ 3, a, a+1, b, a*b ]- string "[";- exprs <- sepBy (expression 0) (char ',' );- string "]";- return $ \varlookup -> OList (map ($varlookup) exprs )- ) <|> ( do -- eg. [ a : 1 : a + 10 ]- string "[";- exprs <- sepBy (expression 0) (char ':' );- string "]";- return $ \varlookup -> OList $ map ONum $ case map (coerceNum.($varlookup)) exprs of- a:[] -> [a]- a:b:[] -> [a .. b]- a:b:c:xs -> [a, a+b .. c]- )<?> "vector/list" )-expression 9 = - let- -- Like in Haskell, we're going to think of functions of - -- many variables as functions that result in functions.- -- So f(a,b) = f(a)(b) :)- applyArgs :: OpenscadObj -> [OpenscadObj] -> OpenscadObj- applyArgs obj [] = obj- applyArgs (OFunc f) (arg:others) = applyArgs (f arg) others - applyArgs 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 ) )- | 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 - obj <- expression 10;- many space- 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 = - 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 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 a b = errorAsAppropriate "divide" a b- in try (( do - -- outer list is multiplication, inner division. objects are - -- expressions and take a varlookup to evaluate.- -- eg. "1*2*3/4/5*6*7/8"- -- [[vl→1],[vl→2],[vl→3,vl→4,vl→5],[vl→6],[vl→7,vl→8]]- exprs <- sepBy1 (sepBy1 (pad $ expression $ n+1) - (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 a b = errorAsAppropriate "append" a b- in try (( do - exprs <- sepBy1 (expression $ n+1) (many space >> string "++" >> many space)- return $ \varlookup -> foldl1 append $ map ($varlookup) exprs;- ) <?> "append") - <|>try (expression $ n+1)--expression n@4 =- let - add (ONum a) (ONum b) = ONum (a+b)- add (OList a) (OList b) = OList $ zipWith add a b- add a b = errorAsAppropriate "add" a b-- sub (ONum a) (ONum b) = ONum (a-b)- sub (OList a) (OList b) = OList $ zipWith sub a b- sub a b = errorAsAppropriate "subtract" a b- in try (( do - -- Similar to multiply & divide- -- eg. "1+2+3-4-5+6-7" - -- [[1],[2],[3,4,5],[6,7]]- exprs <- sepBy1 (sepBy1 (pad $ expression $ n+1) - (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)-expression n@3 = - let- negate (ONum n) = ONum (-n)- negate (OList l) = OList $ map negate l- negate a = OError ["Can't negate " ++ objTypeStr a ++ "(" ++ show a ++ ")"]- in try (do- char '-'- many space- expr <- expression $ n+1- 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 ( 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/Parser/Expr.hs view
@@ -0,0 +1,244 @@+module Graphics.Implicit.ExtOpenScad.Parser.Expr where++import Graphics.Implicit.Definitions+import Text.ParserCombinators.Parsec hiding (State)+import Text.ParserCombinators.Parsec.Expr+import Graphics.Implicit.ExtOpenScad.Definitions+import Graphics.Implicit.ExtOpenScad.Parser.Util++variable :: GenParser Char st Expr+variable = fmap Var variableSymb++literal :: GenParser Char st Expr+literal = + try ( (string "true" >> return (LitE $ OBool True) )+ <|> (string "false" >> return (LitE $ OBool False) )+ <?> "boolean" )+ <|> try ( try (do+ a <- many1 digit+ char '.'+ b <- many digit+ return $ LitE $ ONum (read (a ++ "." ++ b) :: ℝ)+ ) <|> (do+ a <- many1 digit+ return $ LitE $ ONum (read a :: ℝ)+ ) <?> "number" )+ <|> try ( ( do+ string "\""+ strlit <- many $ try (string "\\\"" >> return '\"') <|> try (string "\\n" >> return '\n') <|> ( noneOf "\"\n")+ string "\""+ return $ LitE $ OString strlit+ ) <?> "string" )+ <?> "literal"++-- We represent the priority or 'fixity' of different types of expressions+-- by the Int argument++expression :: Int -> GenParser Char st Expr+expression n@12 = (try literal) <|> (try variable )+ <|> (try (do -- ( 1 + 5 )+ string "("+ expr <- expression 0+ string ")"+ return expr+ ) <?> "bracketed expression" )+ <|> ( try ( do -- [ 3, a, a+1, b, a*b ]+ string "["+ exprs <- sepBy (expression 0) (char ',' )+ string "]"+ return $ ListE exprs+ )<|> try ( do -- ( 1,2,3 )+ string "("+ exprs <- sepBy (expression 0) (char ',' )+ string ")"+ return $ ListE exprs+ ) <|> ( do -- eg. [ a : 1 : a + 10 ]+ string "["+ exprs <- sepBy (expression 0) (char ':' )+ string "]"+ return $ collector "list_gen" exprs+ )<?> "vector/list" )+expression n@11 = + let+ posMatch a =+ (try $ do+ x <- a+ return $ Just x+ ) <|> (return Nothing)+ modifier = + (try $ (do+ genSpace+ string "("+ genSpace+ args <- sepBy + (expression 0) + (try $ genSpace >> char ',' >> genSpace)+ genSpace+ string ")"+ genSpace+ return $ \f -> f :$ args+ <?> "function application"+ )) <|> (try $ (do+ genSpace+ string "["+ i <- pad $ expression 0+ string "]"+ genSpace+ return $ \l -> Var "index" :$ [l, i]+ <?> "list indexing"+ )) <|> (try $ ( do+ string "["+ genSpace+ start <- posMatch $ expression 0+ genSpace+ char ':'+ genSpace+ end <- posMatch $ expression 0+ genSpace+ string "]"+ return $ case (start, end) of+ (Nothing, Nothing) -> id+ (Just s, Nothing) -> \l -> Var "splice" :$ [l, s, LitE OUndefined ]+ (Nothing, Just e ) -> \l -> Var "splice" :$ [l, LitE $ ONum 0, e]+ (Just s, Just e ) -> \l -> Var "splice" :$ [l, s, e]+ <?> "list splicing"))+ + in ( try( do + obj <- expression $ n+1+ genSpace+ mods <- modifier `sepBy` (genSpace)+ genSpace+ return $ foldl (\a b -> b a) obj mods+ ) <?> "list splicing" )+ <|> try (expression $ n+1 )+expression n@10 = + let+ negate x = Var "negate" :$ [x]+ in try (do+ char '-'+ genSpace+ expr <- expression $ n+1+ return $ negate expr+ ) <|> try (do+ char '+'+ genSpace+ expr <- expression $ n+1+ return expr+ ) <|> try (expression $ n+1)+expression n@9 = try (( do + a <- expression (n+1)+ genSpace+ string "^"+ genSpace+ b <- expression n;+ return $ Var "^" :$ [a,b]+ ) <?> "exponentiation")+ <|> try (expression $ n+1)+expression n@8 = + let + div a b = Var "/" :$ [a, b]+ in try (( do + -- outer list is multiplication, inner division. objects are + -- expressions and take a varlookup to evaluate.+ -- eg. "1*2*3/4/5*6*7/8"+ -- [[vl→1],[vl→2],[vl→3,vl→4,vl→5],[vl→6],[vl→7,vl→8]]+ exprs <- sepBy1 (sepBy1 (pad $ expression $ n+1) + (try $ genSpace >> char '/' >> genSpace )) + (try $ genSpace >> char '*' >> genSpace)+ -- [[1],[2],[3,4,5],[6],[7,8]]+ -- [ 1, 2, 3/4/5, 6, 7/8 ]+ -- 1 * 2 * 3/4/5 * 6 * 7/8 + return $ collector "*" $ map (foldl1 div) exprs+ ) <?> "multiplication/division")+ <|>try (expression $ n+1)+expression n@7 =+ let + mod a b = Var "%" :$ [a, b]+ in try (( do + exprs <- sepBy1 (expression $ n+1) (try $ genSpace >> string "%" >> genSpace)+ return $ foldl1 mod exprs+ ) <?> "modulo") + <|>try (expression $ n+1)+expression n@6 =+ try (( do + exprs <- sepBy1 (expression $ n+1) (try $ genSpace >> string "++" >> genSpace)+ return $ collector "++" exprs+ ) <?> "append") + <|>try (expression $ n+1)++expression n@5 =+ let + sub a b = Var "-" :$ [a, b]+ in try (( do + -- Similar to multiply & divide+ -- eg. "1+2+3-4-5+6-7" + -- [[1],[2],[3,4,5],[6,7]]+ exprs <- sepBy1 (sepBy1 (pad $ expression $ n+1) + (try $ genSpace >> char '-' >> genSpace )) + (try $ genSpace >> char '+' >> genSpace)+ return $ collector "+" $ map (foldl1 sub) exprs+ ) <?> "addition/subtraction")+ <|>try (expression $ n+1)+expression n@4 = + try ( do+ firstExpr <- expression $ n+1+ otherComparisonsExpr <- many $ do+ comparison <-+ (try $ string "==" >> return (Var "==") )+ <|> (try $ string "!=" >> return (Var "!=") )+ <|> (try $ string ">=" >> return (Var ">=") )+ <|> (try $ string "<=" >> return (Var "<=") )+ <|> (try $ string ">" >> return (Var ">") )+ <|> (try $ string "<" >> return (Var "<") )+ expr <- expression $ n+1+ return (comparison, expr) + let+ (comparisons, otherExprs) = unzip otherComparisonsExpr+ exprs = firstExpr:otherExprs+ return $ case comparisons of + [] -> firstExpr+ [x] -> x :$ exprs+ _ -> collector "all" [(comparisons!!n) :$ [exprs!!n, exprs!!(n+1)] | n <- [0.. length comparisons - 1] ]+ )<|> try (expression $ n+1)+expression n@3 =+ try (( do+ string "!"+ genSpace+ a <- expression $ n+1+ return $ Var "!" :$ [a]+ )<?> "logical-not")+ <|> try (expression $ n+1)+expression n@2 = + try (( do + a <- expression (n+1)+ genSpace+ string "&&"+ genSpace+ b <- expression n+ return $ Var "&&" :$ [a,b]+ )<?> "logical-and")+ <|> try (( do+ a <- expression $ n+1+ genSpace+ string "||"+ genSpace+ b <- expression n+ return $ Var "||" :$ [a,b]+ )<?> "logical-or")+ <|> try (expression $ n+1)+expression n@1 = + try (( do + a <- expression (n+1)+ genSpace+ string "?"+ genSpace+ b <- expression n+ genSpace+ string ":"+ genSpace+ c <- expression n+ return $ Var "?" :$ [a,b,c]+ ) <?> "ternary")+ <|> try (expression $ n+1)+expression n@0 = try (do { genSpace; expr <- expression $ n+1; genSpace; return expr}) <|> try (expression $ n+1)+
+ Graphics/Implicit/ExtOpenScad/Parser/Statement.hs view
@@ -0,0 +1,276 @@+module Graphics.Implicit.ExtOpenScad.Parser.Statement where++import Graphics.Implicit.Definitions+import Text.ParserCombinators.Parsec hiding (State)+import Text.ParserCombinators.Parsec.Expr+import Graphics.Implicit.ExtOpenScad.Definitions+import Graphics.Implicit.ExtOpenScad.Parser.Util+import Graphics.Implicit.ExtOpenScad.Parser.Expr++parseProgram name s = parse program name s where+ program = do+ sts <- many1 computation+ eof+ return sts++-- | A in our programming openscad-like programming language.+computation :: GenParser Char st StatementI+computation = + (try $ do -- suite statemetns: no semicolon...+ genSpace+ s <- tryMany [+ ifStatementI,+ forStatementI,+ throwAway,+ userModuleDeclaration{-,+ unimplemented "mirror",+ unimplemented "multmatrix",+ unimplemented "color",+ unimplemented "render",+ unimplemented "surface",+ unimplemented "projection",+ unimplemented "import_stl"-}+ -- rotateExtrude+ ]+ genSpace+ return s+ ) <|> (try $ do -- Non suite s. Semicolon needed...+ genSpace+ s <- tryMany [+ echo,+ assignment,+ include--,+ --use+ ]+ genSpace+ char ';'+ genSpace+ return s+ ) <|> (try $ do+ genSpace+ s <- userModule+ genSpace+ return s+ )++{-+-- | A suite of s!+-- What's a suite? Consider:+--+-- union() {+-- sphere(3);+-- }+--+-- The suite was in the braces ({}). Similarily, the+-- following has the same suite:+--+-- union() sphere(3);+--+-- We consider it to be a list of s which+-- are in tern StatementI s.+-- So this parses them.+-}+suite :: GenParser Char st [StatementI]+suite = (fmap return computation <|> do + char '{'+ genSpace+ stmts <- many (try computation)+ genSpace+ char '}'+ return stmts+ ) <?> " suite"+++throwAway :: GenParser Char st StatementI+throwAway = do+ line <- lineNumber+ genSpace+ oneOf "%*"+ genSpace+ computation+ return $ StatementI line DoNothing++-- An included ! Basically, inject another openscad file here...+include :: GenParser Char st StatementI+include = (do+ line <- lineNumber+ use <- (string "include" >> return False)+ <|> (string "use" >> return True )+ genSpace+ string "<"+ filename <- many (noneOf "<>")+ string ">"+ return $ StatementI line $ Include filename use+ ) <?> "include "++-- | An assignment (parser)+assignment :: GenParser Char st StatementI+assignment = + (try $ do+ line <- lineNumber+ pattern <- patternMatcher+ genSpace+ char '='+ genSpace+ valExpr <- expression 0+ return $ StatementI line$ pattern := valExpr+ ) <|> (try $ do + line <- lineNumber+ varSymb <- (try $ string "function" >> space >> genSpace >> variableSymb) + <|> variableSymb+ genSpace+ char '('+ genSpace+ argVars <- sepBy patternMatcher (try $ genSpace >> char ',' >> genSpace)+ genSpace+ char ')'+ genSpace+ char '='+ genSpace+ valExpr <- expression 0+ return $ StatementI line $ Name varSymb := LamE argVars valExpr+ )<?> "assignment "++-- | An echo (parser)+echo :: GenParser Char st StatementI+echo = do+ line <- lineNumber+ string "echo"+ genSpace+ char '('+ genSpace+ exprs <- expression 0 `sepBy` (try $ genSpace >> char ',' >> genSpace)+ genSpace+ char ')'+ return $ StatementI line $ Echo exprs++ifStatementI :: GenParser Char st StatementI+ifStatementI = (do+ line <- lineNumber+ string "if"+ genSpace+ char '('+ bexpr <- expression 0+ char ')'+ genSpace+ sTrueCase <- suite+ genSpace+ sFalseCase <- try (string "else" >> genSpace >> suite ) <|> (return [])+ return $ StatementI line $ If bexpr sTrueCase sFalseCase+ ) <?> "if "++forStatementI :: GenParser Char st StatementI+forStatementI = (do+ line <- lineNumber+ -- a for loop is of the form:+ -- for ( vsymb = vexpr ) loops+ -- eg. for ( a = [1,2,3] ) {echo(a); echo "lol";}+ -- eg. for ( [a,b] = [[1,2]] ) {echo(a+b); echo "lol";}+ string "for"+ genSpace+ char '('+ genSpace+ pattern <- patternMatcher+ genSpace+ char '='+ vexpr <- expression 0+ char ')'+ genSpace+ loopContent <- suite+ return $ StatementI line $ For pattern vexpr loopContent+ ) <?> "for "+++userModule :: GenParser Char st StatementI+userModule = do+ line <- lineNumber+ name <- variableSymb;+ genSpace;+ args <- moduleArgsUnit+ genSpace;+ s <- ( try suite <|> (genSpace >> char ';' >> return []))+ return $ StatementI line $ ModuleCall name args s++userModuleDeclaration :: GenParser Char st StatementI+userModuleDeclaration = do+ line <- lineNumber+ string "module"+ genSpace;+ newModuleName <- variableSymb;+ genSpace;+ args <- moduleArgsUnitDecl+ genSpace;+ s <- suite+ return $ StatementI line $ NewModule newModuleName args s++----------------------++moduleArgsUnit :: GenParser Char st [(Maybe String, Expr)]+moduleArgsUnit = do+ char '(';+ genSpace+ args <- sepBy ( + (try $ do -- eg. a = 12+ symb <- variableSymb+ genSpace+ char '='+ genSpace+ expr <- expression 0+ return $ (Just symb, expr)+ ) <|> (try $ do -- eg. a(x,y) = 12+ symb <- variableSymb;+ genSpace+ char '('+ genSpace+ argVars <- sepBy variableSymb (try $ genSpace >> char ',' >> genSpace)+ char ')'+ genSpace+ char '=';+ genSpace+ expr <- expression 0;+ return $ (Just symb, LamE (map Name argVars) expr)+ ) <|> (do { -- eg. 12+ expr <- expression 0;+ return (Nothing, expr)+ })+ ) (try $ genSpace >> char ',' >> genSpace)+ genSpace + char ')'+ return args++moduleArgsUnitDecl :: GenParser Char st [(String, Maybe Expr)]+moduleArgsUnitDecl = do+ char '(';+ genSpace+ argTemplate <- sepBy ( + (try $ do+ symb <- variableSymb;+ genSpace+ char '='+ genSpace+ expr <- expression 0+ return (symb, Just expr)+ ) <|> (try $ do+ symb <- variableSymb;+ genSpace+ char '('+ genSpace+ argVars <- sepBy variableSymb (try $ genSpace >> char ',' >> genSpace)+ char ')'+ genSpace+ char '='+ genSpace+ expr <- expression 0+ return (symb, Just expr)+ ) <|> (do {+ symb <- variableSymb;+ return (symb, Nothing)+ })+ ) (try $ genSpace >> char ',' >> genSpace);+ genSpace + char ')';+ return argTemplate+++lineNumber = fmap sourceLine getPosition+
+ Graphics/Implicit/ExtOpenScad/Parser/Util.hs view
@@ -0,0 +1,57 @@+module Graphics.Implicit.ExtOpenScad.Parser.Util where++import Graphics.Implicit.Definitions+import Text.ParserCombinators.Parsec hiding (State)+import Text.ParserCombinators.Parsec.Expr+import Graphics.Implicit.ExtOpenScad.Definitions++-- white space, including tabs, newlines and comments+genSpace = many $ + oneOf " \t\n\r" + <|> (try $ do+ string "//"+ many ( noneOf "\n")+ string "\n"+ return ' '+ ) <|> (try $ do+ string "/*"+ manyTill anyChar (try $ string "*/")+ return ' '+ )++pad parser = do+ genSpace+ a <- parser+ genSpace+ return a++tryMany = (foldl1 (<|>)) . (map try)++variableSymb = many1 (noneOf " ,|[]{}()+-*&^%#@!~`'\"\\/;:.,<>?=") <?> "variable"+++patternMatcher :: GenParser Char st Pattern+patternMatcher =+ (do + char '_'+ return Wild+ ) <|> {-( do+ a <- literal+ return $ \obj ->+ if obj == (a undefined)+ then Just (Map.empty)+ else Nothing+ ) <|> -} ( do+ symb <- variableSymb+ return $ Name symb+ ) <|> ( do+ char '['+ genSpace+ components <- patternMatcher `sepBy` (try $ genSpace >> char ',' >> genSpace)+ genSpace+ char ']'+ return $ ListP components+ )+++
Graphics/Implicit/ExtOpenScad/Primitives.hs view
@@ -7,26 +7,25 @@ -- The code is fairly straightforward; an explanation of how -- the first one works is provided. -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ScopedTypeVariables, OverlappingInstances #-} module Graphics.Implicit.ExtOpenScad.Primitives (primitives) where import Graphics.Implicit.Definitions import Graphics.Implicit.ExtOpenScad.Definitions-import Graphics.Implicit.ExtOpenScad.Util import Graphics.Implicit.ExtOpenScad.Util.ArgParser-import Graphics.Implicit.ExtOpenScad.Util.Computation+import Graphics.Implicit.ExtOpenScad.Util.OVal 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)+import qualified Data.Either as Either+import Data.Either (either)+import qualified Control.Monad as Monad+ +import Data.VectorSpace +primitives :: [(String, [OVal] -> ArgParser (IO [OVal]) )]+primitives = [ sphere, cube, square, cylinder, circle, polygon, union, difference, intersect, translate, scale, rotate, extrude, pack, shell, rotateExtrude, unit ] -- **Exmaple of implementing a module** -- sphere is a module without a suite named sphere,@@ -54,11 +53,30 @@ example "cube(4);" -- arguments- size :: Either ℝ ℝ3 <- argument "size"- `doc` "cube size"- center :: Bool <- argument "center" - `doc` "should center?" - `defaultTo` False+ ((x1,x2), (y1,y2), (z1,z2)) <-+ do+ x :: Either ℝ ℝ2 <- argument "x"+ `doc` "x or x-interval"+ y :: Either ℝ ℝ2 <- argument "y"+ `doc` "y or y-interval"+ z :: Either ℝ ℝ2 <- argument "z"+ `doc` "z or z-interval"+ center :: Bool <- argument "center" + `doc` "should center? (non-intervals)" + `defaultTo` False+ let toInterval' = toInterval center+ return (either (toInterval center) id x,+ either (toInterval center) id y,+ either (toInterval center) id z)+ <|> do+ size :: Either ℝ ℝ3 <- argument "size"+ `doc` "square size"+ center :: Bool <- argument "center" + `doc` "should center?" + `defaultTo` False+ let (x,y, z) = either (\w -> (w,w,w)) id size+ return (toInterval center x, toInterval center y, toInterval center z)+ r :: ℝ <- argument "r" `doc` "radius of rounding" `defaultTo` 0@@ -69,30 +87,40 @@ 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)+ addObj3 $ Prim.rect3R r (x1, y1, z1) (x2, y2, z2) - case size of- Right (x,y,z) -> addObj3 $ rect3 x y z- Left w -> addObj3 $ rect3 w w w square = moduleWithoutSuite "square" $ do -- examples + example "square(x=[-2,2], y=[-1,5]);" example "square(size = [3,4], center = true, r = 0.5);" example "square(4);" -- arguments- size :: Either ℝ ℝ2 <- argument "size"- `doc` "square size"- center :: Bool <- argument "center" - `doc` "should center?" - `defaultTo` False+ ((x1,x2), (y1,y2)) <-+ do+ x :: Either ℝ ℝ2 <- argument "x"+ `doc` "x or x-interval"+ y :: Either ℝ ℝ2 <- argument "y"+ `doc` "y or y-interval"+ center :: Bool <- argument "center" + `doc` "should center? (non-intervals)" + `defaultTo` False+ let toInterval' = toInterval center+ return (either (toInterval center) id x,+ either (toInterval center) id y)+ <|> do+ size :: Either ℝ ℝ2 <- argument "size"+ `doc` "square size"+ center :: Bool <- argument "center" + `doc` "should center?" + `defaultTo` False+ let (x,y) = either (\w -> (w,w)) id size+ return (toInterval center x, toInterval center y)+ r :: ℝ <- argument "r" `doc` "radius of rounding" `defaultTo` 0@@ -103,17 +131,7 @@ 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+ addObj2 $ Prim.rectR r (x1, y1) (x2, y2) @@ -127,8 +145,8 @@ r :: ℝ <- argument "r" `defaultTo` 1 `doc` "radius of cylinder"- h :: ℝ <- argument "h"- `defaultTo` 1+ h :: Either ℝ ℝ2 <- argument "h"+ `defaultTo` (Left 1) `doc` "height of cylinder" r1 :: ℝ <- argument "r1" `defaultTo` 1@@ -149,6 +167,11 @@ test "cylinder(r=5, h=10, $fn = 6);" `eulerCharacteristic` 0 + let+ (h1, h2) = either (toInterval center) id h+ dh = h2 - h1+ shift = if h1 == 0 then id else Prim.translate (0,0,h1)+ -- The result is a computation state modifier that adds a 3D object, -- based on the args. addObj3 $ if r1 == 1 && r2 == 1@@ -156,13 +179,9 @@ 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+ obj3 = Prim.extrudeR 0 obj2 dh+ in shift $ obj3+ else shift $ Prim.cylinder2 r1 r2 dh circle = moduleWithoutSuite "circle" $ do @@ -179,9 +198,9 @@ test "circle(r=10);" `eulerCharacteristic` 0 - if fn < 3- then addObj2 $ Prim.circle r- else addObj2 $ Prim.polygonR 0 $+ addObj2 $ if fn < 3+ then Prim.circle r+ else Prim.polygonR 0 $ let sides = fromIntegral fn in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]] @@ -199,74 +218,83 @@ `defaultTo` 0 case paths of [] -> addObj2 $ Prim.polygonR 0 points- _ -> noChange;--+ _ -> return $ return [] -union = moduleWithSuite "union" $ \suite -> do+union = moduleWithSuite "union" $ \children -> 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+ return $ return $ if r > 0+ then objReduce (Prim.unionR r) (Prim.unionR r) children+ else objReduce Prim.union Prim.union children -intersect = moduleWithSuite "intersection" $ \suite -> do+intersect = moduleWithSuite "intersection" $ \children -> 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+ return $ return $ if r > 0+ then objReduce (Prim.intersectR r) (Prim.intersectR r) children+ else objReduce Prim.intersect Prim.intersect children -difference = moduleWithSuite "difference" $ \suite -> do+difference = moduleWithSuite "difference" $ \children -> 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+ return $ return $ if r > 0+ then objReduce (Prim.differenceR r) (Prim.differenceR r) children+ else objReduce Prim.difference Prim.difference children -translate = moduleWithSuite "translate" $ \suite -> do+translate = moduleWithSuite "translate" $ \children -> 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)+ (x,y,z) <- + do+ x :: ℝ <- argument "x"+ `doc` "x amount to translate";+ y :: ℝ <- argument "y"+ `doc` "y amount to translate";+ z :: ℝ <- argument "z"+ `doc` "z amount to translate"+ `defaultTo` 0;+ return (x,y,z);+ <|> do+ v :: Either ℝ (Either ℝ2 ℝ3) <- argument "v"+ `doc` "vector to translate by"+ return $ case v of+ Left x -> (x,0,0)+ Right (Left (x,y) ) -> (x,y,0)+ Right (Right (x,y,z)) -> (x,y,z) - 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)+ return $ return $ + objMap (Prim.translate (x,y)) (Prim.translate (x,y,z)) children deg2rad x = x / 180.0 * pi -- This is mostly insane-rotate = moduleWithSuite "rotate" $ \suite -> do+rotate = moduleWithSuite "rotate" $ \children -> do a <- argument "a" `doc` "value to rotate by; angle or list of angles"+ v <- argument "v" `defaultTo` (0, 0, 1)+ `doc` "Vector to rotate around if a is a single angle" -- 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 )+ return $ return $ caseOType a $+ ( \θ ->+ objMap (Prim.rotate $ deg2rad θ) (Prim.rotate3V (deg2rad θ) v) children+ ) <||> ( \(yz,zx,xy) ->+ objMap (Prim.rotate $ deg2rad xy ) (Prim.rotate3 (deg2rad yz, deg2rad zx, deg2rad xy) ) children+ ) <||> ( \(yz,zx) ->+ objMap (id ) (Prim.rotate3 (deg2rad yz, deg2rad zx, 0)) children+ ) <||> ( \_ -> [] ) -scale = moduleWithSuite "scale" $ \suite -> do+scale = moduleWithSuite "scale" $ \children -> do example "scale(2) square(5);" example "scale([2,3]) square(5);"@@ -277,15 +305,15 @@ let scaleObjs strech2 strech3 = - getAndTransformSuiteObjs suite (Prim.scale strech2) (Prim.scale strech3)+ objMap (Prim.scale strech2) (Prim.scale strech3) children - case v of- Left x -> scaleObjs (x,0) (x,0,0)- Right (Left (x,y)) -> scaleObjs (x,y) (x,y,0.0)+ return $ return $ case v of+ Left x -> scaleObjs (x,1) (x,1,1)+ Right (Left (x,y)) -> scaleObjs (x,y) (x,y,1) Right (Right (x,y,z)) -> scaleObjs (x,y) (x,y,z) -extrude = moduleWithSuite "linear_extrude" $ \suite -> do- example "extrude(10) square(5);"+extrude = moduleWithSuite "linear_extrude" $ \children -> do+ example "linear_extrude(10) square(5);" height :: Either ℝ (ℝ -> ℝ -> ℝ) <- argument "height" `defaultTo` (Left 1) `doc` "height to extrude to..."@@ -316,21 +344,40 @@ 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 :: (VectorSpace a, Fractional (Scalar a)) => Either a (ℝ -> a) -> ℝ -> a+ funcify (Left val) h = realToFrac (h/heightn) *^ val funcify (Right f ) h = f h twist' = fmap funcify twist scale' = fmap funcify scale translate' = fmap funcify translate - 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'+ return $ return $ obj2UpMap (+ \obj -> case height of+ Left constHeight | isNothing twist && isNothing scale && isNothing translate ->+ shiftAsNeeded $ Prim.extrudeR r obj constHeight+ _ -> + shiftAsNeeded $ Prim.extrudeRM r twist' scale' translate' obj height'+ ) children +rotateExtrude = moduleWithSuite "rotate_extrude" $ \children -> do+ example "rotate_extrude() translate(20) circle(10);" + totalRot :: ℝ <- argument "a" `defaultTo` 360+ `doc` "angle to sweep"+ r :: ℝ <- argument "r" `defaultTo` 0+ translate :: Either ℝ2 (ℝ -> ℝ2) <- argument "translate" `defaultTo` Left (0,0)++ let+ n = fromIntegral $ round $ totalRot / 360+ cap = (360*n /= totalRot) + || (Either.either ( /= (0,0)) (\f -> f 0 /= f totalRot) ) translate+ capM = if cap then Just r else Nothing+ + return $ return $ obj2UpMap (Prim.rotateExtrude totalRot capM translate) children+++ {-rotateExtrudeStatement = moduleWithSuite "rotate_extrude" $ \suite -> do h <- realArgument "h" center <- boolArgumentWithDefault "center" False@@ -339,14 +386,14 @@ getAndModUpObj2s suite (\obj -> Prim.extrudeRMod r (\θ (x,y) -> (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ)) ) obj h) -} -shell = moduleWithSuite "shell" $ \suite -> do+shell = moduleWithSuite "shell" $ \children-> do w :: ℝ <- argument "w" `doc` "width of the shell..." - getAndTransformSuiteObjs suite (Prim.shell w) (Prim.shell w)+ return $ return $ objMap (Prim.shell w) (Prim.shell w) children -- Not a perenant solution! Breaks if can't pack.-pack = moduleWithSuite "pack" $ \suite -> do+pack = moduleWithSuite "pack" $ \children -> do example "pack ([45,45], sep=2) { circle(10); circle(10); circle(10); circle(10); }" @@ -357,18 +404,86 @@ `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] )+ return $+ let (obj2s, obj3s, others) = divideObjs children+ in if not $ null obj3s+ then case Prim.pack3 size sep obj3s of+ Just solution -> return $ OObj3 solution : (map OObj2 obj2s ++ others) Nothing -> do putStrLn "Can't pack given objects in given box with present algorithm"- return (varlookup2, obj2s, obj3s)- else case Prim.pack2 size sep obj2s2 of- Just solution -> return (varlookup2, obj2s ++ [solution], obj3s)+ return children+ else case Prim.pack2 size sep obj2s of+ Just solution -> return $ OObj2 solution : others Nothing -> do putStrLn "Can't pack given objects in given box with present algorithm"- return (varlookup2, obj2s, obj3s)+ return children +unit = moduleWithSuite "unit" $ \children -> do++ example "unit(\"inch\") {..}"++ -- arguments+ unit :: String <- argument "unit"+ `doc` "the unit you wish to work in"++ let + mmRatio "inch" = Just 25.4+ mmRatio "in" = mmRatio "inch"+ mmRatio "foot" = Just 304.8+ mmRatio "ft" = mmRatio "foot"+ mmRatio "yard" = Just 914.4+ mmRatio "yd" = mmRatio "yard"+ mmRatio "mm" = Just 1+ mmRatio "cm" = Just 10+ mmRatio "dm" = Just 100+ mmRatio "m" = Just 1000+ mmRatio "km" = Just 1000000+ mmRatio "µm" = Just 0.001+ mmRatio "um" = mmRatio "µm"+ mmRatio "nm" = Just 0.0000001+ mmRatio _ = Nothing++ -- The actual work...+ return $ case mmRatio unit of+ Nothing -> do+ putStrLn $ "unrecognized unit " ++ unit+ return children+ Just r -> + return $ objMap (Prim.scale (r,r)) (Prim.scale (r,r,r)) children+++---------------++(<|>) :: ArgParser a -> ArgParser a -> ArgParser a+(<|>) = Monad.mplus++moduleWithSuite name modArgMapper = (name, modArgMapper)+moduleWithoutSuite name modArgMapper = (name, \suite -> modArgMapper)++addObj3 :: SymbolicObj3 -> ArgParser (IO [OVal])+addObj3 x = return $ return [OObj3 x]++addObj2 :: SymbolicObj2 -> ArgParser (IO [OVal])+addObj2 x = return $ return [OObj2 x]++objMap obj2mod obj3mod (x:xs) = case x of+ OObj2 obj2 -> OObj2 (obj2mod obj2) : objMap obj2mod obj3mod xs+ OObj3 obj3 -> OObj3 (obj3mod obj3) : objMap obj2mod obj3mod xs+ a -> a : objMap obj2mod obj3mod xs+objMap _ _ [] = []++objReduce obj2reduce obj3reduce l = case divideObjs l of+ ( [], [], others) -> others+ ( [], obj3s, others) -> OObj3 (obj3reduce obj3s) : others+ (obj2s, [], others) -> OObj2 (obj2reduce obj2s) : others+ (obj2s, obj3s, others) -> OObj2 (obj2reduce obj2s) : OObj3 (obj3reduce obj3s) : others++obj2UpMap obj2upmod (x:xs) = case x of+ OObj2 obj2 -> OObj3 (obj2upmod obj2) : obj2UpMap obj2upmod xs+ a -> a : obj2UpMap obj2upmod xs+obj2UpMap _ [] = []++toInterval center h = + if center+ then (-h/2, h/2)+ else (0, h)
− Graphics/Implicit/ExtOpenScad/Statements.hs
@@ -1,482 +0,0 @@--- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)--- Released under the GNU GPL, see LICENSE---- We'd like to parse openscad code, with some improvements, for backwards compatability.---- Implement statements for things other than primitive objects!--{-# 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.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)---- | A statement in our programming openscad-like programming language.-computationStatement :: GenParser Char st ComputationStateModifier-computationStatement = - (try $ do -- suite statemetns: no semicolon...- many space- s <- tryMany [- ifStatement,- forStatement,- throwAway,- userModuleDeclaration,- unimplemented "mirror",- unimplemented "multmatrix",- unimplemented "color",- unimplemented "render",- unimplemented "surface",- unimplemented "projection",- unimplemented "rotate_extrude",- unimplemented "import_stl"- -- rotateExtrudeStatement- ]- many space- return s- ) <|> (try $ do -- Non suite statements. Semicolon needed...- many space- s <- tryMany [- echoStatement,- assigmentStatement,- includeStatement,- useStatement- ]- many space- char ';'- many space- return s- )<|> (try $ many space >> comment)- <|> (try $ do- many space- s <- userModule- many space- return s- )------ | A suite of statements!--- What's a suite? Consider:------ union() {--- sphere(3);--- }------ The suite was in the braces ({}). Similarily, the--- following has the same suite:------ union() sphere(3);------ We consider it to be a list of statements which--- are in tern ComputationStateModifier s.--- So this parses them.--suite :: GenParser Char st [ComputationStateModifier]-suite = (liftM return computationStatement <|> do - char '{'- many space- stmts <- many (try computationStatement)- many space- char '}'- return stmts- ) <?> "statement suite"----- | We think of comments as statements that do nothing. It's just convenient.-comment = - (((try $ do- string "//"- many ( noneOf "\n")- string "\n"- ) <|> (do- string "/*"- manyTill anyChar (try $ string "*/")- )) >> return id) <?> "comment"--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 "<"- filename <- many (noneOf "<>")- string ">"- return $ \ ioWrappedState -> do- state@(varlookup,obj2s,obj3s) <- ioWrappedState;- 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 "<"- filename <- many (noneOf "<>")- string ">"- return $ \ ioWrappedState -> do- state@(varlookup, _, _) <- ioWrappedState;- 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 (varlookup,[],[])) result- ) <?> "use statement"----- | An assignment statement (parser)-assigmentStatement :: GenParser Char st ComputationStateModifier-assigmentStatement = - (try $ do- line <- fmap sourceLine getPosition- pattern <- patternMatcher- many space- char '='- many space- valExpr <- expression 0- return $ \ ioWrappedState -> do- state@(varlookup, obj2s, obj3s) <- ioWrappedState- let- val = valExpr varlookup- 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 - line <- fmap sourceLine getPosition- varSymb <- (try $ string "function" >> many1 space >> variableSymb) - <|> variableSymb- many space- char '('- many space- argVars <- sepBy variableSymb (many space >> char ',' >> many space)- many space- char ')'- many space- char '='- many space- valExpr <- expression 0- return $ \ ioWrappedState -> do- (varlookup, obj2s, obj3s) <- ioWrappedState- let- makeFunc baseExpr (argVar:xs) varlookup' = OFunc $ - \argObj -> makeFunc baseExpr xs (insert argVar argObj varlookup')- makeFunc baseExpr [] varlookup' = baseExpr varlookup'- val = makeFunc valExpr argVars varlookup- 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- exprs <- expression 0 `sepBy` (many space >> char ',' >> many space)- many space- char ')'- return $ \ ioWrappedState -> do- state@(varlookup, _, _) <- ioWrappedState- 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 '('- bexpr <- expression 0- char ')'- many space- statementsTrueCase <- suite- many space- statementsFalseCase <- try (string "else" >> many space >> suite ) <|> (return [])- return $ \ ioWrappedState -> do- state@(varlookup, _, _) <- ioWrappedState- 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,b] = [[1,2]] ) {echo(a+b); echo "lol";}- string "for"- many space- char '('- many space- pattern <- patternMatcher- many space- char '='- vexpr <- expression 0- char ')'- many space- loopStatements <- suite- return $ \ ioWrappedState -> do- -- a for loop unpackages the state from an io monad- state@(varlookup,_,_) <- ioWrappedState;- let- -- each iteration of the loop consists of unpacking the state- loopOnce :: - ComputationState -- ^ The state at this point in the loop- -> OpenscadObj -- ^ The value of vsymb for this iteration- -> ComputationState -- ^ The resulting state- loopOnce ioWrappedState val = do- state@(varlookup, a, b) <- ioWrappedState;- let- 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- 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- many space;- statements <- suite- return $ \ ioWrappedState -> do- state@(varlookup, obj2s, obj3s) <- ioWrappedState- case argMap - (map ($varlookup) unnamed) - (map (\(a,b) -> (a, b varlookup)) named) (argHandeler statements)- of- (Just computationModifier, []) -> computationModifier (return state)- (Nothing, []) -> 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---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---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)---
− Graphics/Implicit/ExtOpenScad/Util.hs
@@ -1,176 +0,0 @@--- 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 Data.Maybe (isJust,isNothing)-import Control.Monad (forM_)---type Any = OpenscadObj--caseOType = flip ($)--infixr 2 <||>--(<||>) :: forall desiredType out. (OTypeMirror desiredType)- => (desiredType -> out) - -> (OpenscadObj -> out)- -> (OpenscadObj -> out)--(<||>) f g = \input ->- let- coerceAttempt = fromOObj input :: Maybe desiredType- in - if isJust coerceAttempt -- ≅ (/= Nothing) but no Eq req- then f $ (\(Just a) -> a) coerceAttempt- else g input--moduleArgsUnit :: - GenParser Char st ([VariableLookup -> OpenscadObj], [(String, VariableLookup -> OpenscadObj)])-moduleArgsUnit = do- char '(';- many space;- args <- sepBy ( - (try $ do -- eg. a = 12- symb <- variableSymb;- many space;- char '=';- many space;- expr <- expression 0;- return $ Right (symb, expr);- ) <|> (try $ do -- eg. a(x,y) = 12- symb <- variableSymb;- many space;- char '('- many space- argVars <- sepBy variableSymb (many space >> char ',' >> many space)- char ')'- many space- char '=';- many space;- expr <- expression 0;- let- makeFunc baseExpr (argVar:xs) varlookup' = OFunc $ - \argObj -> makeFunc baseExpr xs (insert argVar argObj varlookup')- makeFunc baseExpr [] varlookup' = baseExpr varlookup'- funcExpr = makeFunc expr argVars- return $ Right (symb, funcExpr);- ) <|> (do { -- eg. 12- expr <- expression 0;- return $ Left expr;- })- ) (many space >> char ',' >> many space);- many space; - char ')';- let- isRight (Right a) = True- isRight _ = False- named = map (\(Right a) -> a) $ filter isRight $ args- unnamed = map (\(Left a) -> a) $ filter (not . isRight) $ args- in return (unnamed, named)--moduleArgsUnitDecl :: - GenParser Char st (VariableLookup -> ArgParser (VariableLookup -> VariableLookup))-moduleArgsUnitDecl = do- char '(';- many space;- 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- many space- a <- parser- 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
@@ -1,73 +1,47 @@--- 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+{-# LANGUAGE ViewPatterns, RankNTypes, ScopedTypeVariables #-}+module Graphics.Implicit.ExtOpenScad.Util.ArgParser where +import Graphics.Implicit.Definitions import Graphics.Implicit.ExtOpenScad.Definitions--import qualified Data.Map as Map-import qualified Data.Maybe as Maybe+import Graphics.Implicit.ExtOpenScad.Util.OVal 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.+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import Control.Monad 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+ return a = APTerminator a -- Now things get more interesting. We need to describe how (>>=) works. -- Let's get the hard ones out of the way first. -- ArgParser actually - (ArgParser str fallback doc f) >>= g = ArgParser str fallback doc (\a -> (f a) >>= g)- (ArgParserFailIf b errmsg child) >>= g = ArgParserFailIf b errmsg (child >>= g)+ (AP str fallback doc f) >>= g = AP str fallback doc (\a -> (f a) >>= g)+ (APFailIf b errmsg child) >>= g = APFailIf b errmsg (child >>= g) -- These next to is easy, they just pass the work along to their child- (ArgParserExample str child) >>= g = ArgParserExample str (child >>= g)- (ArgParserTest str tests child) >>= g = ArgParserTest str tests (child >>= g)+ (APExample str child) >>= g = APExample str (child >>= g)+ (APTest str tests child) >>= g = APTest str tests (child >>= g) -- And an ArgParserTerminator happily gives away the value it contains- (ArgParserTerminator a) >>= g = g a+ (APTerminator a) >>= g = g a+ (APBranch bs) >>= g = APBranch $ map (>>= g) bs +instance MonadPlus ArgParser where+ mzero = APFailIf True "" undefined+ mplus (APBranch as) (APBranch bs) = APBranch ( as ++ bs )+ mplus (APBranch as) b = APBranch ( as ++ [b] )+ mplus a (APBranch bs) = APBranch ( [a] ++ bs )+ mplus a b = APBranch [ a , b ]+ -- * ArgParser building functions -- ** argument and combinators argument :: forall desiredType. (OTypeMirror desiredType) => String -> ArgParser desiredType argument name = - ArgParser name Nothing "" $ \oObjVal -> do+ AP name Nothing "" $ \oObjVal -> do let val = fromOObj oObjVal :: Maybe desiredType errmsg = case oObjVal of@@ -75,46 +49,53 @@ ++ ": " ++ 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+ APFailIf (Maybe.isNothing val) errmsg $ APTerminator $ (\(Just a) -> a) val -doc (ArgParser name defMaybeVal oldDoc next) doc =- ArgParser name defMaybeVal doc next+doc (AP name defMaybeVal _ next) newDoc = AP name defMaybeVal newDoc 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+defaultTo (AP name oldDefMaybeVal doc next) newDefVal = + AP name (Just $ toOObj newDefVal) doc next -- ** example example :: String -> ArgParser ()-example str = ArgParserExample str (return ())+example str = APExample str (return ()) -- * test and combinators test :: String -> ArgParser ()-test str = ArgParserTest str [] (return ())+test str = APTest str [] (return ()) eulerCharacteristic :: ArgParser a -> Int -> ArgParser a-eulerCharacteristic (ArgParserTest str tests child) χ =- ArgParserTest str ((EulerCharacteristic χ) : tests) child+eulerCharacteristic (APTest str tests child) χ =+ APTest str ((EulerCharacteristic χ) : tests) child -- * Tools for handeling ArgParsers -- | Apply arguments to an ArgParser argMap :: - [OpenscadObj] -- ^ Unnamed Arguments- -> [(String, OpenscadObj)] -- ^ Named Arguments+ [(Maybe String, OVal)] -- ^ arguments -> ArgParser a -- ^ ArgParser to apply them to -> (Maybe a, [String]) -- ^ (result, error messages) -argMap a b = argMap2 a (Map.fromList b)+argMap args = argMap2 unnamedArgs (Map.fromList namedArgs) where+ unnamedArgs = map snd $ filter (Maybe.isNothing . fst) args+ namedArgs = map (\(a,b) -> (Maybe.fromJust a, b)) $ filter (Maybe.isJust . fst) args +argMap2 :: [OVal] -> Map.Map String OVal -> ArgParser a -> (Maybe a, [String]) -argMap2 :: [OpenscadObj] -> Map.Map String OpenscadObj -> ArgParser a -> (Maybe a, [String])+argMap2 uArgs nArgs (APBranch branches) =+ foldl1 merge solutions where+ solutions = map (argMap2 uArgs nArgs) branches+ merge a@(Just _, []) _ = a+ merge _ b@(Just _, []) = b+ merge a@(Just _, _) _ = a+ merge (Nothing, _) a = a -argMap2 unnamedArgs namedArgs (ArgParser name fallback _ f) = +argMap2 unnamedArgs namedArgs (AP name fallback _ f) = case Map.lookup name namedArgs of Just a -> argMap2 unnamedArgs @@ -126,23 +107,24 @@ Just b -> argMap2 [] namedArgs (f b) Nothing -> (Nothing, ["No value and no default for argument " ++ name]) -argMap2 a b (ArgParserTerminator val) = +argMap2 a b (APTerminator val) = (Just val,- if length a + Map.size b > 0+ if not (null a && Map.null b) then ["unused arguments"] else [] ) -argMap2 a b (ArgParserFailIf test err child) = +argMap2 a b (APFailIf 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 (APExample str child) = argMap2 a b child -argMap2 a b (ArgParserTest str tests child) = argMap2 a b child+argMap2 a b (APTest str tests child) = argMap2 a b child +{- -- | We need a format to extract documentation into data Doc = Doc String [DocPart] deriving (Show)@@ -183,4 +165,4 @@ -- To look at this one would almost certainly be death (exception) getArgParserDocs (ArgParserTerminator _ ) = return [] -+-}
− Graphics/Implicit/ExtOpenScad/Util/Computation.hs
@@ -1,79 +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, 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/ExtOpenScad/Util/OVal.hs view
@@ -0,0 +1,137 @@++{-# LANGUAGE ViewPatterns, RankNTypes, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, OverlappingInstances #-}++module Graphics.Implicit.ExtOpenScad.Util.OVal where++import Graphics.Implicit.Definitions+import Graphics.Implicit.ExtOpenScad.Definitions+import qualified Control.Monad as Monad+import Data.Maybe (isJust)++-- | We'd like to be able to turn OVals into a given Haskell type+class OTypeMirror a where+ fromOObj :: OVal -> Maybe a+ toOObj :: a -> OVal++instance OTypeMirror OVal 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 OVal to a -> b isn't always safe; use a -> Maybe b"+ ++ " (trace: " ++ show oInput ++ " -> " ++ show oOutput ++ " )"+ fromOObj _ = Nothing+ toOObj f = OFunc $ \oObj -> + case fromOObj oObj :: Maybe a of+ Nothing -> OError ["bad input type"]+ Just obj -> toOObj $ f obj+++instance forall a b. (OTypeMirror a, OTypeMirror b) => OTypeMirror (Either a b) where+ fromOObj (fromOObj -> Just (x :: a)) = Just $ Left x+ fromOObj (fromOObj -> Just (x :: b)) = Just $ Right x+ fromOObj _ = Nothing++ toOObj (Right x) = toOObj x+ toOObj (Left x) = toOObj x++oTypeStr (OUndefined) = "Undefined"+oTypeStr (OBool _ ) = "Bool"+oTypeStr (ONum _ ) = "Number"+oTypeStr (OList _ ) = "List"+oTypeStr (OString _ ) = "String"+oTypeStr (OFunc _ ) = "Function"+oTypeStr (OModule _ ) = "Module"+oTypeStr (OError _ ) = "Error"++getErrors :: OVal -> Maybe String+getErrors (OError er) = Just $ head er+getErrors (OList l) = Monad.msum $ map getErrors l+getErrors _ = Nothing+++type Any = OVal++caseOType = flip ($)++infixr 2 <||>++(<||>) :: forall desiredType out. (OTypeMirror desiredType)+ => (desiredType -> out) + -> (OVal -> out)+ -> (OVal -> out)++(<||>) f g = \input ->+ let+ coerceAttempt = fromOObj input :: Maybe desiredType+ in + if isJust coerceAttempt -- ≅ (/= Nothing) but no Eq req+ then f $ (\(Just a) -> a) coerceAttempt+ else g input+++divideObjs children = + (map fromOObj2 . filter isOObj2 $ children,+ map fromOObj3 . filter isOObj3 $ children,+ filter (not . isOObj) $ children)+ where+ isOObj2 (OObj2 _) = True+ isOObj2 _ = False+ isOObj3 (OObj3 _) = True+ isOObj3 _ = False+ isOObj (OObj2 _) = True+ isOObj (OObj3 _) = True+ isOObj _ = False+ fromOObj2 (OObj2 x) = x+ fromOObj3 (OObj3 x) = x++
+ Graphics/Implicit/ExtOpenScad/Util/StateC.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE ViewPatterns, RankNTypes, ScopedTypeVariables #-}++module Graphics.Implicit.ExtOpenScad.Util.StateC where++import Graphics.Implicit.Definitions+import Text.ParserCombinators.Parsec hiding (State)+import Graphics.Implicit.ExtOpenScad.Definitions+import Graphics.Implicit.ExtOpenScad.Util.ArgParser++import qualified Data.Map as Map+import Data.Map (Map)+import Control.Monad.State (State,StateT, get, put, modify, liftIO)+import System.FilePath((</>))+++type CompState = (VarLookup, [OVal], FilePath, (), ())+type StateC = StateT CompState IO++getVarLookup :: StateC VarLookup+getVarLookup = fmap (\(a,_,_,_,_) -> a) get++modifyVarLookup :: (VarLookup -> VarLookup) -> StateC ()+modifyVarLookup = modify . (\f (a,b,c,d,e) -> (f a, b, c, d, e))++lookupVar :: String -> StateC (Maybe OVal)+lookupVar name = do+ varlookup <- getVarLookup+ return $ Map.lookup name varlookup++pushVals :: [OVal] -> StateC ()+pushVals vals = modify (\(a,b,c,d,e) -> (a, vals ++ b,c,d,e))++getVals :: StateC [OVal]+getVals = do+ (a,b,c,d,e) <- get+ return b++putVals :: [OVal] -> StateC ()+putVals vals = do+ (a,b,c,d,e) <- get+ put (a,vals,c,d,e)++withPathShiftedBy :: FilePath -> StateC a -> StateC a+withPathShiftedBy pathShift s = do+ (a,b,path,d,e) <- get+ put (a,b, path </> pathShift, d, e)+ x <- s+ (a',b',_,d',e') <- get+ put (a', b', path, d', e')+ return x++getPath :: StateC FilePath+getPath = do+ (a,b,c,d,e) <- get+ return c++getRelPath :: FilePath -> StateC FilePath+getRelPath relPath = do+ path <- getPath+ return $ path </> relPath++errorC lineN err = liftIO $ putStrLn $ "At " ++ show lineN ++ ": " ++ err++mapMaybeM f (Just a) = do+ b <- f a+ return (Just b)+mapMaybeM f Nothing = return Nothing
Graphics/Implicit/MathUtil.hs view
@@ -4,21 +4,21 @@ module Graphics.Implicit.MathUtil (rmax, rmin, rmaximum, rminimum, distFromLineSeg, pack, box3sWithin) where import Data.List+import Data.VectorSpace+import Data.AffineSpace 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)+distFromLineSeg :: ℝ2 -> (ℝ2,ℝ2) -> ℝ+distFromLineSeg p (a,b) = magnitude (closest .-. p) where- ab = b S.- a- nab = (1 / S.norm ab) S.* ab- ap = p S.- a- d = nab S.⋅ ap+ ab = b ^-^ a+ ap = p ^-^ a+ d = normalized ab ⋅ ap closest | d < 0 = a- | d > S.norm ab = b- | otherwise = a S.+ d S.* nab+ | d > magnitude ab = b+ | otherwise = a ^+^ d *^ normalized ab
Graphics/Implicit/ObjectUtil/GetBox2.hs view
@@ -3,15 +3,36 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} -module Graphics.Implicit.ObjectUtil.GetBox2 (getBox2) where+module Graphics.Implicit.ObjectUtil.GetBox2 (getBox2, getDist2) 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)+import Data.VectorSpace +isEmpty :: Box2 -> Bool+isEmpty = (== ((0,0), (0,0)))++pointsBox :: [ℝ2] -> Box2+pointsBox points =+ let+ (xs, ys) = unzip points+ in+ ((minimum xs, minimum ys), (maximum xs, maximum ys))++unionBoxes :: [Box2] -> Box2+unionBoxes boxes =+ let+ (leftbot, topright) = unzip $ filter (not.isEmpty) boxes+ (lefts, bots) = unzip leftbot+ (rights, tops) = unzip topright+ in+ ((minimum lefts, minimum bots), (maximum rights, maximum tops))++outsetBox :: ℝ -> Box2 -> Box2+outsetBox r (a,b) =+ (a ^-^ (r,r), b ^+^ (r,r))+ getBox2 :: SymbolicObj2 -> Box2 -- Primitives@@ -24,21 +45,10 @@ -- (Rounded) CSG getBox2 (Complement2 symbObj) = - ((-infty, -infty), (infty, infty)) where infty = (1::ℝ)/(0 ::ℝ)+ ((-infty, -infty), (infty, infty)) where infty = 1/0 getBox2 (UnionR2 r symbObjs) =- 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))+ outsetBox r $ unionBoxes (map getBox2 symbObjs) getBox2 (DifferenceR2 r symbObjs) = let @@ -64,9 +74,9 @@ let (a,b) = getBox2 symbObj in- if (a,b) == ((0,0),(0,0))+ if isEmpty (a,b) then ((0,0),(0,0))- else (a+v, b+v)+ else (a^+^v, b^+^v) getBox2 (Scale2 s symbObj) = let@@ -76,32 +86,41 @@ 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]+ ((x1,y1), (x2,y2)) = getBox2 symbObj+ rotate (x,y) = (cos(θ)*x - sin(θ)*y, sin(θ)*x + cos(θ)*y) in- ((minx, miny), (maxx, maxy))+ pointsBox [ rotate (x1, y1)+ , rotate (x1, y2)+ , rotate (x2, y1)+ , rotate (x2, y2)+ ] -- Boundary mods getBox2 (Shell2 w symbObj) = - let- (a,b) = getBox2 symbObj- d = w/(2.0::ℝ)- in- (a - (d,d), b + (d,d))+ outsetBox (w/2) $ getBox2 symbObj getBox2 (Outset2 d symbObj) =- let- (a,b) = getBox2 symbObj- in- (a - (d,d), b + (d,d))+ outsetBox d $ getBox2 symbObj -- Misc getBox2 (EmbedBoxedObj2 (obj,box)) = box++-- Get the maximum distance (read upper bound) an object is from a point.+-- Sort of a circular ++getDist2 :: ℝ2 -> SymbolicObj2 -> ℝ++getDist2 p (UnionR2 r objs) = r + maximum [getDist2 p obj | obj <- objs ]++getDist2 p (Translate2 v obj) = getDist2 (p ^+^ v) obj++getDist2 p (Circle r) = magnitude p + r++getDist2 (x,y) symbObj =+ let+ ((x1,y1), (x2,y2)) = getBox2 symbObj+ in+ sqrt ((max (abs (x1 - x)) (abs (x2 - x)))^2 + (max (abs (y1 - y)) (abs (y2 - y)))^2)++getDist2 p (PolygonR r points) = + r + maximum [magnitude (p ^-^ p') | p' <- points]
Graphics/Implicit/ObjectUtil/GetBox3.hs view
@@ -5,14 +5,23 @@ 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 qualified Data.Maybe as Maybe+import Data.VectorSpace -import Graphics.Implicit.ObjectUtil.GetBox2 (getBox2)+import Graphics.Implicit.ObjectUtil.GetBox2 (getBox2, getDist2) +import Debug.Trace++isEmpty :: Box3 -> Bool+isEmpty = (== ((0,0,0), (0,0,0)))++outsetBox :: ℝ -> Box3 -> Box3+outsetBox r (a,b) =+ (a ^-^ (r,r,r), b ^+^ (r,r,r))+ getBox3 :: SymbolicObj3 -> Box3 -- Primitives@@ -24,7 +33,7 @@ -- (Rounded) CSG getBox3 (Complement3 symbObj) = - ((-infty, -infty, -infty), (infty, infty, infty)) where infty = (1::ℝ)/(0 ::ℝ)+ ((-infty, -infty, -infty), (infty, infty, infty)) where infty = 1/0 getBox3 (UnionR3 r symbObjs) = ((left-r,bot-r,inward-r), (right+r,top+r,out+r)) where @@ -68,7 +77,7 @@ let (a,b) = getBox3 symbObj in- (a+v, b+v)+ (a^+^v, b^+^v) getBox3 (Scale3 s symbObj) = let@@ -79,21 +88,16 @@ 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]+ d = (sqrt 3 *) $ maximum $ map abs [x1, x2, y1, y2, z1, z2] +getBox3 (Rotate3V _ v symbObj) = getBox3 (Rotate3 v symbObj)+ -- Boundary mods-getBox3 (Shell3 w symbObj) = - let- (a,b) = getBox3 symbObj- d = w/(2.0::ℝ)- in- (a - (d,d,d), b + (d,d,d))+getBox3 (Shell3 w symbObj) =+ outsetBox (w/2) $ getBox3 symbObj getBox3 (Outset3 d symbObj) =- let- (a,b) = getBox3 symbObj- in- (a - (d,d,d), b + (d,d,d))+ outsetBox d $ getBox3 symbObj -- Misc getBox3 (EmbedBoxedObj3 (obj,box)) = box@@ -111,34 +115,63 @@ ((bx1+ax1, by1+ax1, ay2), (bx2+ax2, by2+ax2, ay2)) -getBox3 (ExtrudeRM r twist scale translate symbObj (Left h)) = +getBox3 (ExtrudeRM r twist scale translate symbObj eitherh) = let+ range = [0, 0.1 .. 1.0]+ ((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]+ (dx,dy) = (x2 - x1, y2 - y1)+ (xrange, yrange) = (map (\s -> x1+s*dx) $ range, map (\s -> y1+s*dy) $ range )++ h = case eitherh of+ Left h -> h+ Right hf -> hmax + 0.2*(hmax-hmin)+ where+ hs = [hf (x,y) | x <- xrange, y <- yrange]+ (hmin, hmax) = (minimum hs, maximum hs)+ + hrange = map (h*) $ range++ sval = case scale of+ Nothing -> 1+ Just scale' -> maximum $ map (abs . scale') hrange+ + (twistXmin, twistYmin, twistXmax, twistYmax) = case twist of+ Nothing -> (smin x1, smin y1, smax x2, smax y2)+ where+ smin y = min y (sval * y)+ smax y = max y (sval * y)+ Just _ -> (-d, -d, d, d)+ where d = sval * getDist2 (0,0) symbObj+ + translate' = fromMaybe (const (0,0)) translate+ (tvalsx, tvalsy) = unzip . map (translate' . (h*)) $ hrange (tminx, tminy) = (minimum tvalsx, minimum tvalsy) (tmaxx, tmaxy) = (maximum tvalsx, maximum tvalsy) in- ((-d+tminx, -d+tminy, 0),(d+tmaxx, d+tmaxy, h)) + ((twistXmin + tminx, twistYmin + tminy, 0),(twistXmax + tmaxx, twistYmax + tmaxy, h)) -getBox3 (ExtrudeRM r twist scale translate symbObj (Right hf)) = ++getBox3 (RotateExtrude _ _ (Left (xshift,yshift)) symbObj) = 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)+ r = max x2 (x2 + xshift) in- ((-d+tminx, -d+tminy, 0),(d+tmaxx, d+tmaxy, h))+ ((-r, -r, min y1 (y1 + yshift)),(r, r, max y2 (y2 + yshift)))++getBox3 (RotateExtrude rot _ (Right f) symbObj) = + let+ ((x1,y1),(x2,y2)) = getBox2 symbObj+ (xshifts, yshifts) = unzip [f θ | θ <- [0 , rot / 10 .. rot] ]+ xmax = maximum xshifts+ ymax = maximum yshifts+ ymin = minimum yshifts+ xmax' = if xmax > 0 then xmax * 1.1 else if xmax < - x1 then 0 else xmax+ ymax' = ymax + 0.1 * (ymax - ymin)+ ymin' = ymin - 0.1 * (ymax - ymin)+ r = x2 + xmax'+ in+ ((-r, -r, y1 + ymin'),(r, r, y2 + ymax'))
Graphics/Implicit/ObjectUtil/GetImplicit2.hs view
@@ -5,18 +5,16 @@ 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.VectorSpace 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::ℝ)]+ [abs (x-dx/2-x1) - dx/2, abs (y-dy/2-y1) - dy/2] where (dx, dy) = (x2-x1, y2-y1) getImplicit2 (Circle r ) = @@ -25,18 +23,18 @@ 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+ pair n = (points !! n, points !! (mod (n + 1) (length points) ) )+ pairs = [ pair n | n <- [0 .. (length points) - 1] ]+ relativePairs = map (\(a,b) -> (a ^-^ p, b ^-^ p) ) pairs crossing_points =- [x2 - y2*(x2-x1)/(y2-y1) | ((x1,y1), (x2,y2)) <-relativePairs,+ [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 :: ℝ)+ minimum dists * if isIn then -1 else 1 -- (Rounded) CSG getImplicit2 (Complement2 symbObj) = @@ -75,7 +73,7 @@ let obj = getImplicit2 symbObj in- \p -> obj (p-v)+ \p -> obj (p ^-^ v) getImplicit2 (Scale2 s@(sx,sy) symbObj) = let@@ -94,7 +92,7 @@ let obj = getImplicit2 symbObj in- \p -> abs (obj p) - w/(2.0::ℝ)+ \p -> abs (obj p) - w/2 getImplicit2 (Outset2 d symbObj) = let
Graphics/Implicit/ObjectUtil/GetImplicit3.hs view
@@ -1,3 +1,4 @@+ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU GPL, see LICENSE @@ -5,11 +6,13 @@ 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 qualified Data.Either as Either+import Data.VectorSpace +import Data.AffineSpace+import Data.Cross (cross3) import Graphics.Implicit.ObjectUtil.GetImplicit2 (getImplicit2) @@ -17,7 +20,7 @@ -- 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::ℝ)]+ [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 ) = @@ -67,32 +70,43 @@ let obj = getImplicit3 symbObj in- \p -> obj (p-v)+ \p -> obj (p ^-^ v) getImplicit3 (Scale3 s@(sx,sy,sz) symbObj) = let obj = getImplicit3 symbObj+ k = (sx*sy*sz)**(1/3) in- \p -> (maximum [sx, sy, sz]) * obj (p ⋯/ s)+ \p -> k * obj (p ⋯/ s) -getImplicit3 (Rotate3 (yz, xz, xy) symbObj) = +getImplicit3 (Rotate3 (yz, zx, 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)+ rotateYZ θ obj = \(x,y,z) -> obj ( x, cos(θ)*y + sin(θ)*z, cos(θ)*z - sin(θ)*y)+ rotateZX :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)+ rotateZX θ obj = \(x,y,z) -> obj ( cos(θ)*x - sin(θ)*z, y, cos(θ)*z + sin(θ)*x) rotateXY :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ) rotateXY θ obj = \(x,y,z) -> obj ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x, z) in- rotateYZ yz $ rotateXZ xz $ rotateXY xy $ obj+ rotateYZ yz $ rotateZX zx $ rotateXY xy $ obj +getImplicit3 (Rotate3V θ axis symbObj) =+ let+ axis' = normalized axis+ obj = getImplicit3 symbObj+ in+ \v -> obj $ + v ^* cos(θ) + ^-^ (axis' `cross3` v) ^* sin(θ) + ^+^ (axis' ^* (axis' <.> (v ^* (1 - cos(θ)))))+ -- Boundary mods getImplicit3 (Shell3 w symbObj) = let obj = getImplicit3 symbObj in- \p -> abs (obj p) - w/(2::ℝ)+ \p -> abs (obj p) - w/2 getImplicit3 (Outset3 d symbObj) = let@@ -108,7 +122,7 @@ let obj = getImplicit2 symbObj in- \(x,y,z) -> MathUtil.rmax r (obj (x,y)) (abs (z - h/(2::ℝ)) - h/(2::ℝ))+ \(x,y,z) -> MathUtil.rmax r (obj (x,y)) (abs (z - h/2) - h/2) getImplicit3 (ExtrudeRM r twist scale translate symbObj height) = let@@ -127,8 +141,8 @@ 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::ℝ))+ (obj . rotateVec (-k*twist' z) . scaleVec (scale' z) . (\a -> a ^-^ translate' z) $ (x,y))+ (abs (z - h/2) - h/2) getImplicit3 (ExtrudeOnEdgeOf symbObj1 symbObj2) =@@ -137,3 +151,44 @@ obj2 = getImplicit2 symbObj2 in \(x,y,z) -> obj1 (obj2 (x,y), z)++++getImplicit3 (RotateExtrude totalRotation round translate symbObj) = + let+ tau = 2 * pi+ k = tau / 360+ totalRotation' = totalRotation*k+ obj = getImplicit2 symbObj+ capped = Maybe.isJust round+ round' = Maybe.fromMaybe 0 round+ translate' :: ℝ -> ℝ2+ translate' = Either.either + (\(a,b) -> \θ -> (a*θ/totalRotation', b*θ/totalRotation')) + (. (/k))+ translate+ in+ \(x,y,z) -> minimum $ do+ + let + r = sqrt (x^2 + y^2)+ θ = atan2 y x+ ns :: [Int]+ ns =+ if capped+ then -- we will cap a different way, but want leeway to keep the function cont+ [-1 .. (ceiling (totalRotation' / tau) :: Int) + (1 :: Int)]+ else+ [0 .. floor $ (totalRotation' - θ) /tau]+ n <- ns+ let+ θvirt = fromIntegral n * tau + θ+ (rshift, zshift) = translate' θvirt + rz_pos = (r - rshift, z - zshift)+ return $+ if capped+ then MathUtil.rmax round' + (abs (θvirt - (totalRotation' / 2)) - (totalRotation' / 2))+ (obj rz_pos)+ else obj rz_pos+
Graphics/Implicit/Primitives.hs view
@@ -164,9 +164,13 @@ extrudeRM = ExtrudeRM +rotateExtrude = RotateExtrude+ extrudeOnEdgeOf = ExtrudeOnEdgeOf rotate3 = Rotate3++rotate3V = Rotate3V pack3 :: ℝ2 -> ℝ -> [SymbolicObj3] -> Maybe SymbolicObj3
− Graphics/Implicit/SaneOperators.hs
@@ -1,200 +0,0 @@--- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)--- Released under the GNU GPL, see LICENSE--{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances, UndecidableInstances #-}---- We're going to be working with vectors, etc, a lot.--- I'd rather not have to break every stupid vector into--- its components to add them or scale them...--module Graphics.Implicit.SaneOperators where--import qualified Prelude as P-import Prelude hiding ((+),(-),(*),(/))--import Graphics.Implicit.Definitions---- * Num is too big a class and doesn't make sense for, say, vectors.--class Additive a b c | a b -> c where- (+) :: a -> b -> c- infixl 6 +--class Multiplicative a b c | a b -> c where- (*) :: a -> b -> c- infixl 7 *--class AdditiveInvertable a where- additiveInverse :: a -> a--class MultiplicativeInvertable a where- multiplicativeInverse :: a -> a--class Normable a where- norm :: a -> ℝ--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.---{-instance Num a => Additive a a a where- a + b = a P.+ b--instance Num a => Multiplicative a a a where- a * b = a P.* b--instance Num a => AdditiveInvertable a where- additiveInverse a = negate a--instance Fractional a => MultiplicativeInvertable a where- multiplicativeInverse a = 1 P./ a-}---- So, we do this instead. :(--instance Additive ℝ ℝ ℝ where- a + b = a P.+ b--instance Multiplicative ℝ ℝ ℝ where- a * b = a P.* b--instance AdditiveInvertable ℝ where- additiveInverse a = negate a--instance MultiplicativeInvertable ℝ where- multiplicativeInverse a = 1 P./ a--instance Additive ℕ ℕ ℕ where- a + b = a P.+ b--instance Multiplicative ℕ ℕ ℕ where- a * b = a P.* b--instance AdditiveInvertable ℕ where- additiveInverse a = negate a---instance Additive ℝ ℕ ℝ where- a + b = a P.+ (fromIntegral b)--instance Multiplicative ℝ ℕ ℝ where- a * b = a P.* (fromIntegral b)--instance Additive ℕ ℝ ℝ where- a + b = (fromIntegral a) P.+ b--instance Multiplicative ℕ ℝ ℝ where- a * b = (fromIntegral a) P.* b---(-) :: (Additive a b c) => (AdditiveInvertable b) => a -> b -> c-x - y = x + (additiveInverse y)-infixl 6 ---(/) :: (Multiplicative a b c) => (MultiplicativeInvertable b) => a -> b -> c-x / y = x * (multiplicativeInverse y)-infixl 7 /----instance Additive ℝ2 ℝ2 ℝ2 where- (x1, y1) + (x2, y2) = (x1+x2, y1+y2)--instance Additive ℝ3 ℝ3 ℝ3 where- (x1, y1, z1) + (x2, y2, z2) = (x1+x2, y1+y2, z1+z2)--{-instance (Additive a b c, Additive d e f) => Additive (a,d) (b,e) (c,f) where- (x1, y1) + (x2, y2) = (x1+x2, y1+y2)--instance (Additive a b c, Additive d e f, Additive g h i) => Additive (a,d,g) (b,e,h) (c,f,i) where- (x1, y1, z1) + (x2, y2, z2) = (x1+x2, y1+y2, z1+z2)-}--instance Multiplicative ℝ ℝ2 ℝ2 where- s * (x,y) = (s*x, s*y)--instance Multiplicative ℝ2 ℝ ℝ2 where- (x,y)*s = (s*x, s*y)--instance Multiplicative ℝ ℝ3 ℝ3 where- s * (x,y,z) = (s*x, s*y, s*z)--instance Multiplicative ℝ3 ℝ ℝ3 where- (x,y,z) * s = (s*x, s*y, s*z)--instance AdditiveInvertable ℝ2 where- additiveInverse (x, y) = (additiveInverse x, additiveInverse y)--instance AdditiveInvertable ℝ3 where- additiveInverse (x, y, z) = (additiveInverse x, additiveInverse y, additiveInverse z)--{-instance (AdditiveInvertable a, AdditiveInvertable b) => AdditiveInvertable (a,b) where- additiveInverse (x, y) = (additiveInverse x, additiveInverse y)--instance (AdditiveInvertable a, AdditiveInvertable b, AdditiveInvertable c) => AdditiveInvertable (a,b,c) where- additiveInverse (x, y, z) = (additiveInverse x, additiveInverse y, additiveInverse z)-}----instance (Additive a b c) => Additive (d -> a) (d -> b) (d -> c) where- f + g = \p -> f p + g p--instance (Multiplicative a b c) => Multiplicative (d -> a) (d -> b) (d -> c) where- f * g = \p -> f p * g p---instance Normable ℝ where- norm a = abs a--instance Normable ℝ2 where- norm (a, b) = sqrt ((a**2) + (b**2))--instance Normable ℝ3 where- norm (a, b, c) = sqrt ((a**2) + (b**2) + (c**2))--instance InnerProductSpace ℝ where- x ⋅ y = x*y--instance InnerProductSpace ℝ2 where- (a1, a2) ⋅ (b1, b2) = a1*b1 + a2*b2--instance InnerProductSpace ℝ3 where- (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,137 +1,192 @@ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU GPL, see LICENSE -{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ViewPatterns, PatternGuards #-} -- 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.Environment (getArgs) import System.IO (openFile, IOMode (ReadMode), hGetContents, hClose)-import Graphics.Implicit (runOpenscad, writeSVG, writeSTL, writeOBJ, writeSCAD3, writeSCAD2, writeGCodeHacklabLaser, writeTHREEJS)-import Graphics.Implicit.ExtOpenScad.Definitions (OpenscadObj (ONum))+import Graphics.Implicit (runOpenscad, writeSVG, writeBinSTL, writeOBJ, writeSCAD3, writeSCAD2, writeGCodeHacklabLaser, writeTHREEJS, writePNG2, writePNG3)+import Graphics.Implicit.ExtOpenScad.Definitions (OVal (ONum)) import Graphics.Implicit.ObjectUtil (getBox2, getBox3)-import Graphics.Implicit.Definitions (xmlErrorOn, errorMessage)-import Data.Map as Map+import Graphics.Implicit.Definitions (xmlErrorOn, errorMessage, SymbolicObj2, SymbolicObj3)+import qualified Data.Map as Map hiding (null)+import Data.Maybe as Maybe+import Data.Char+import Data.Monoid (Monoid, mappend)+import Data.Tuple (swap) import Text.ParserCombinators.Parsec (errorPos, sourceLine) import Text.ParserCombinators.Parsec.Error import Data.IORef (writeIORef)+import Data.AffineSpace+import Control.Applicative+-- The following is needed to ensure backwards/forwards compatibility+-- make sure we don't import (<>) in new versions.+import Options.Applicative (fullDesc, progDesc, header, info, helper, help, str, argument, switch, value, long, short, option, metavar, nullOption, reader, execParser, (&), Parser)+import System.FilePath --- | strip a .scad or .escad file to its basename.-strip :: String -> String-strip filename = case reverse filename of- 'd':'a':'c':'s':'.':xs -> reverse xs- 'd':'a':'c':'s':'e':'.':xs -> reverse xs- _ -> filename+-- Backwards compatibility with old versions of Data.Monoid:+infixr 6 <>+(<>) :: Monoid a => a -> a -> a+(<>) = mappend --- | Get the file type ending of a file--- eg. "foo.stl" -> "stl"-fileType filename = reverse $ beforeFirstPeriod $ reverse filename+data ExtOpenScadOpts = ExtOpenScadOpts+ { outputFile :: Maybe FilePath+ , outputFormat :: Maybe OutputFormat+ , resolution :: Maybe Float+ , xmlError :: Bool+ , inputFile :: FilePath+ }++data OutputFormat+ = SVG+ | SCAD+ | PNG+ | GCode+ | STL+ | OBJ+ deriving (Show, Eq, Ord)++formatExtensions :: [(String, OutputFormat)]+formatExtensions =+ [ ("svg", SVG)+ , ("scad", SCAD)+ , ("png", PNG)+ , ("ngc", GCode)+ , ("stl", STL)+ , ("obj", OBJ)+ ]++readOutputFormat :: String -> Maybe OutputFormat+readOutputFormat ext = lookup (map toLower ext) formatExtensions++guessOutputFormat :: FilePath -> OutputFormat+guessOutputFormat fileName =+ maybe (error $ "Unrecognized output format: "<>ext) id+ $ readOutputFormat $ tail ext where- beforeFirstPeriod [] = [] - beforeFirstPeriod ('.':xs) = []- beforeFirstPeriod ( x:xs) = x : beforeFirstPeriod xs+ (_,ext) = splitExtension fileName +extOpenScadOpts :: Parser ExtOpenScadOpts+extOpenScadOpts =+ ExtOpenScadOpts+ <$> nullOption+ ( short 'o'+ <> long "output"+ <> value Nothing+ <> metavar "FILE"+ <> reader (pure . str)+ <> help "Output file name"+ )+ <*> nullOption+ ( short 'f'+ <> long "format"+ <> value Nothing+ <> metavar "FORMAT"+ <> help "Output format"+ <> reader (pure . readOutputFormat)+ )+ <*> option+ ( short 'r'+ <> long "resolution"+ <> value Nothing+ <> metavar "RES"+ <> help "Approximation quality"+ )+ <*> switch+ ( long "xml-error"+ & help "Report XML errors"+ )+ <*> argument str ( metavar "FILE" )+ getRes (Map.lookup "$res" -> Just (ONum res), _, _) = res -getRes (_, _, obj:_) = min (minimum [x,y,z]/2) ((x*y*z)**(1/3) / 22)- where+getRes (varlookup, _, obj:_) =+ let ((x1,y1,z1),(x2,y2,z2)) = getBox3 obj (x,y,z) = (x2-x1, y2-y1, z2-z1)+ in case Maybe.fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of+ ONum qual | qual > 0 -> min (minimum [x,y,z]/2) ((x*y*z/qual)**(1/3) / 22)+ _ -> min (minimum [x,y,z]/2) ((x*y*z )**(1/3) / 22) -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 (varlookup, obj:_, _) =+ let+ (p1,p2) = getBox2 obj+ (x,y) = p2 .-. p1+ in case Maybe.fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of+ ONum qual | qual > 0 -> min (min x y/2) ((x*y/qual)**0.5 / 30)+ _ -> min (min x y/2) ((x*y )**0.5 / 30) 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 -> - 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 = 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+export3 :: Maybe OutputFormat -> Float -> FilePath -> SymbolicObj3 -> IO ()+export3 posFmt res output obj =+ case posFmt of+ Just STL -> writeBinSTL res output obj+ Just SCAD -> writeSCAD3 res output obj+ Just OBJ -> writeOBJ res output obj+ Just PNG -> writePNG3 res output obj+ Nothing -> writeBinSTL res output obj+ Just fmt -> putStrLn $ "Unrecognized 3D format: "<>show fmt - +export2 :: Maybe OutputFormat -> Float -> FilePath -> SymbolicObj2 -> IO ()+export2 posFmt res output obj =+ case posFmt of+ Just SVG -> writeSVG res output obj+ Just SCAD -> writeSCAD2 res output obj+ Just PNG -> writePNG2 res output obj+ Just GCode -> writeGCodeHacklabLaser res output obj+ Nothing -> writeSVG res output obj+ Just fmt -> putStrLn $ "Unrecognized 2D format: "<>show fmt main :: IO() main = do- args <- getArgs- 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+ args <- execParser+ $ info (helper <*> extOpenScadOpts)+ ( fullDesc+ <> progDesc "Extended OpenSCAD"+ <> header "extopenscad - Extended OpenSCAD"+ )+ writeIORef xmlErrorOn (xmlError args)++ content <- readFile (inputFile args)+ let format = + case () of+ _ | Just fmt <- outputFormat args -> Just $ fmt+ _ | Just file <- outputFile args -> Just $ guessOutputFormat file+ _ -> Nothing+ case runOpenscad content of+ Left err -> putStrLn $ show $ err+ Right openscadProgram -> do+ s@(vars, obj2s, obj3s) <- openscadProgram+ let res = maybe (getRes s) id (resolution args)+ let basename = fst (splitExtension $ inputFile args)+ let posDefExt = case format of+ Just f -> lookup f (map swap formatExtensions)+ Nothing -> Nothing -- We don't know the format -- it will be 2D/3D default+ {-let Just defExtension = lookup format (map swap formatExtensions)+ in maybe (fst (splitExtension $ inputFile args)<>"."<>defExtension) id+ $ outputFile args-}+ case (obj2s, obj3s) of+ ([], [obj]) -> do+ let output = fromMaybe + (basename ++ "." ++ fromMaybe "stl" posDefExt)+ (outputFile args)+ putStrLn $ "Rendering 3D object to " ++ output+ putStrLn $ "With resolution " ++ show res+ putStrLn $ "In box " ++ show (getBox3 obj)+ putStrLn $ show obj+ export3 format res output obj+ ([obj], []) -> do+ let output = fromMaybe + (basename ++ "." ++ fromMaybe "stl" posDefExt)+ (outputFile args)+ putStrLn $ "Rendering 2D object to " ++ output+ putStrLn $ "With resolution " ++ show res+ putStrLn $ "In box " ++ show (getBox2 obj)+ putStrLn $ show obj+ export2 format res output obj+ ([], []) -> putStrLn "No objects to render"+ _ -> putStrLn "Multiple objects, what do you want to render?"
implicit.cabal view
@@ -1,5 +1,5 @@ Name: implicit-Version: 0.0.2+Version: 0.0.3 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.@@ -18,13 +18,24 @@ Build-Depends: base >= 3 && < 5,+ filepath,+ directory,+ optparse-applicative, parsec,- hashmap,+ unordered-containers, parallel, containers,- plugins,- deepseq-+ deepseq,+ vector-space,+ text,+ mtl,+ bytestring,+ blaze-builder,+ blaze-markup,+ blaze-svg,+ storable-endian,+ JuicyPixels+ ghc-options: -O2 -optc-O3 -threaded@@ -47,41 +58,46 @@ ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances,- ViewPatterns+ ViewPatterns,+ OverloadedStrings Exposed-Modules: Graphics.Implicit Graphics.Implicit.Definitions+ Graphics.Implicit.Primitives Graphics.Implicit.Export Graphics.Implicit.MathUtil- Graphics.Implicit.SaneOperators Graphics.Implicit.ExtOpenScad Graphics.Implicit.ObjectUtil Other-Modules:- Graphics.Implicit.Primitives 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.Parser.Util+ Graphics.Implicit.ExtOpenScad.Parser.Statement+ Graphics.Implicit.ExtOpenScad.Parser.Expr+ Graphics.Implicit.ExtOpenScad.Definitions Graphics.Implicit.ExtOpenScad.Primitives- Graphics.Implicit.ExtOpenScad.Statements- Graphics.Implicit.ExtOpenScad.Util- Graphics.Implicit.ExtOpenScad.Util.Computation+ Graphics.Implicit.ExtOpenScad.Eval.Statement+ Graphics.Implicit.ExtOpenScad.Eval.Expr+ Graphics.Implicit.ExtOpenScad.Util.StateC Graphics.Implicit.ExtOpenScad.Util.ArgParser+ Graphics.Implicit.ExtOpenScad.Util.OVal Graphics.Implicit.Export.Definitions Graphics.Implicit.Export.MarchingSquares Graphics.Implicit.Export.MarchingSquaresFill Graphics.Implicit.Export.SymbolicObj2 Graphics.Implicit.Export.SymbolicObj3+ Graphics.Implicit.Export.RayTrace Graphics.Implicit.Export.PolylineFormats Graphics.Implicit.Export.TriangleMeshFormats Graphics.Implicit.Export.NormedTriangleMeshFormats Graphics.Implicit.Export.SymbolicFormats Graphics.Implicit.Export.Util+ Graphics.Implicit.Export.TextBuilderUtils Graphics.Implicit.Export.Symbolic.Rebound2 Graphics.Implicit.Export.Symbolic.Rebound3 Graphics.Implicit.Export.Render@@ -92,6 +108,7 @@ Graphics.Implicit.Export.Render.Interpolate Graphics.Implicit.Export.Render.RefineSegs Graphics.Implicit.Export.Render.TesselateLoops+ Graphics.Implicit.Export.Render.HandlePolylines Executable extopenscad