implicit 0.1.0 → 0.2.0
raw patch · 77 files changed
+2619/−755 lines, 77 filesdep +bytestring-builderdep −downloadsetup-changed
Dependencies added: bytestring-builder
Dependencies removed: download
Files
- .gitignore +9/−0
- CONTRIBUTORS +28/−0
- Examples/example1.scad +4/−0
- Examples/example10.escad +2/−0
- Examples/example11.hs +9/−0
- Examples/example12.hs +8/−0
- Examples/example13.hs +8/−0
- Examples/example2.escad +5/−0
- Examples/example3.escad +10/−0
- Examples/example4.escad +10/−0
- Examples/example5.escad +10/−0
- Examples/example6.escad +10/−0
- Examples/example7.escad +10/−0
- Examples/example8.escad +7/−0
- Examples/example9.escad +4/−0
- Graphics/Implicit.hs +1/−1
- Graphics/Implicit/Definitions.hs +16/−8
- Graphics/Implicit/Export.hs +9/−9
- Graphics/Implicit/Export/DiscreteAproxable.hs +9/−9
- Graphics/Implicit/Export/MarchingSquares.hs +51/−56
- Graphics/Implicit/Export/MarchingSquaresFill.hs +43/−31
- Graphics/Implicit/Export/PolylineFormats.hs +22/−19
- Graphics/Implicit/Export/RayTrace.hs +15/−15
- Graphics/Implicit/Export/Render.hs +62/−53
- Graphics/Implicit/Export/Render/Definitions.hs +4/−9
- Graphics/Implicit/Export/Render/GetLoops.hs +5/−6
- Graphics/Implicit/Export/Render/GetSegs.hs +3/−3
- Graphics/Implicit/Export/Render/HandlePolylines.hs +13/−12
- Graphics/Implicit/Export/Render/HandleSquares.hs +4/−4
- Graphics/Implicit/Export/Render/Interpolate.hs +23/−21
- Graphics/Implicit/Export/Render/RefineSegs.hs +4/−3
- Graphics/Implicit/Export/Render/TesselateLoops.hs +12/−7
- Graphics/Implicit/Export/Symbolic/CoerceSymbolic2.hs +29/−0
- Graphics/Implicit/Export/Symbolic/CoerceSymbolic3.hs +35/−0
- Graphics/Implicit/Export/Symbolic/Rebound2.hs +1/−1
- Graphics/Implicit/Export/Symbolic/Rebound3.hs +1/−1
- Graphics/Implicit/Export/SymbolicFormats.hs +15/−16
- Graphics/Implicit/Export/SymbolicObj2.hs +4/−6
- Graphics/Implicit/Export/SymbolicObj3.hs +7/−5
- Graphics/Implicit/Export/TextBuilderUtils.hs +4/−4
- Graphics/Implicit/Export/TriangleMeshFormats.hs +11/−7
- Graphics/Implicit/Export/Util.hs +1/−1
- Graphics/Implicit/ExtOpenScad.hs +4/−4
- Graphics/Implicit/ExtOpenScad/Default.hs +24/−26
- Graphics/Implicit/ExtOpenScad/Definitions.hs +12/−9
- Graphics/Implicit/ExtOpenScad/Eval/Expr.hs +6/−8
- Graphics/Implicit/ExtOpenScad/Eval/Statement.hs +15/−17
- Graphics/Implicit/ExtOpenScad/Parser/Expr.hs +90/−39
- Graphics/Implicit/ExtOpenScad/Parser/Statement.hs +33/−38
- Graphics/Implicit/ExtOpenScad/Parser/Util.hs +14/−10
- Graphics/Implicit/ExtOpenScad/Primitives.hs +32/−31
- Graphics/Implicit/ExtOpenScad/Util/ArgParser.hs +10/−10
- Graphics/Implicit/ExtOpenScad/Util/OVal.hs +49/−54
- Graphics/Implicit/ExtOpenScad/Util/StateC.hs +5/−4
- Graphics/Implicit/MathUtil.hs +18/−14
- Graphics/Implicit/ObjectUtil/GetBox2.hs +20/−13
- Graphics/Implicit/ObjectUtil/GetBox3.hs +14/−9
- Graphics/Implicit/ObjectUtil/GetImplicit2.hs +39/−32
- Graphics/Implicit/ObjectUtil/GetImplicit3.hs +26/−24
- Makefile +78/−0
- README.md +312/−0
- Setup.hs +1/−0
- bench/ParserBench.hs +0/−61
- docgen.hs +88/−0
- hacking.md +174/−0
- implicit.cabal +21/−9
- programs/Benchmark.hs +14/−4
- programs/ParserBench.hs +61/−0
- programs/extopenscad.hs +24/−16
- programs/implicitsnap.hs +53/−11
- stack.yaml +29/−0
- tests/Main.hs +19/−5
- tests/NOTES +2/−0
- tests/ParserSpec/Expr.hs +129/−0
- tests/ParserSpec/Statement.hs +93/−0
- tests/ParserSpec/Util.hs +79/−0
- tests/tobacco_mesophyll_protoplast_fusion_device.escad +493/−0
+ .gitignore view
@@ -0,0 +1,9 @@+*~+*.o+*.hi+*.svg+*.png+*.ps+*.stl+dist/+Setup
+ CONTRIBUTORS view
@@ -0,0 +1,28 @@+A big thanks to our past and present contributors:++shkoo -- Nils McCarthy -- nils@shkoo.com+diffoperator -- Nikhil Sarda -- nikhilsarda.iitkgp@gmail.com++matthewSorensen -- Matthew D Sorensen +krakrjak -- Zac Slade -- krakrjak@gmail.com+bergey -- Daniel Bergey -- bergey@teallabs.org+colah -- Chris Olah -- CristopherOlah.Co@gmail.com+rotty -- Andreas Rottmann -- a.rottmann@gmx.at+bgamari -- Ben Gamari -- BGamari@gmail.com+TheGrum -- Howard C. Shaw III -- howardcshaw@gmail.com+katee -- Kate Murphy -- hello@kate.io+andres-erbsen -- Andres Erbsen -- andreser@mit.edu+tolomea -- Gordon Wrigley -- Gordon.Wrigley@gmail.com+silky -- Noon van der Silk -- noonsilk@gmail.com+mmachenry -- Mike Machenry -- Mike.Machenry@gmail.com+julialongtin -- Julia Longtin -- JuliaL@TuringLace.com+chicagoduane -- Duane Johnson -- Duane.Johnson@gmail.com+l29ah -- Sergey Alirzaev -- zl29ah@gmail.com+firegurafiku -- Pavel Kretov -- firegurafiku@gmail.com+gambogi -- Matthew Gambogi -- m@gambogi.com+kpe -- ?? -- ??++Thanks as well, to raghuugare. Due to not being contactable,+his code has been removed during the license update.++
+ Examples/example1.scad view
@@ -0,0 +1,4 @@+union() {+ square([80,80]);+ translate ([80,80]) circle(30);+}
+ Examples/example10.escad view
@@ -0,0 +1,2 @@+// Example10.escad -- map!.+echo(map(cos, [0, pi/2, pi]));
+ Examples/example11.hs view
@@ -0,0 +1,9 @@+-- Example 11 - the union of a square and a circle.+import Graphics.Implicit++out = union [+ rectR 0 (-40,-40) (40,40),+ translate (40,40) (circle 30) ]++main = writeSVG 2 "example11.svg" out+
+ Examples/example12.hs view
@@ -0,0 +1,8 @@+-- Example 12 - the rounded union of a square and a circle.+import Graphics.Implicit++out = unionR 14 [+ rectR 0 (-40,-40) (40,40),+ translate (40,40) (circle 30) ]+ +main = writeSVG 2 "example12.svg" out
+ Examples/example13.hs view
@@ -0,0 +1,8 @@+-- Example 13 - the rounded union of a cube and a sphere.+import Graphics.Implicit++out = union [+ rect3R 0 (0,0,0) (20,20,20),+ translate (20,20,20) (sphere 15) ]++main = writeSTL 1 "example13.stl" out
+ Examples/example2.escad view
@@ -0,0 +1,5 @@+//example2.escad -- A rounded union of a square and a circle.+union(r=14) {+ square([80,80]);+ translate ([80,80]) circle(30);+}
+ Examples/example3.escad view
@@ -0,0 +1,10 @@+// example3.escad -- the extruded product of the union of five circles.+linear_extrude (height = 40, center=true){+ union ( r = 8) {+ circle (10);+ translate ([22,0]) circle (10);+ translate ([0,22]) circle (10);+ translate ([-22,0]) circle (10);+ translate ([0,-22]) circle (10);+ }+}
+ Examples/example4.escad view
@@ -0,0 +1,10 @@+// example4.escad -- the twisted extruded product of the union of five circles.+linear_extrude (height = 40, center=true, twist=90){+ union ( r = 8) {+ circle (10);+ translate ([22,0]) circle (10);+ translate ([0,22]) circle (10);+ translate ([-22,0]) circle (10);+ translate ([0,-22]) circle (10);+ }+}
+ Examples/example5.escad view
@@ -0,0 +1,10 @@+// example5.escad -- the variably twisted extruded product of the union of 5 circles.+linear_extrude (height = 40, center=true, twist(h) = 35*cos(h*2*pi/60)) {+ union ( r = 8) {+ circle (10);+ translate ([22,0]) circle (10);+ translate ([0,22]) circle (10);+ translate ([-22,0]) circle (10);+ translate ([0,-22]) circle (10);+ }+}
+ Examples/example6.escad view
@@ -0,0 +1,10 @@+// example6.escad -- A rounded extrusion of the rounded union of 5 circles.+linear_extrude (height = 40, center=true, r=5){+ union ( r = 8) {+ circle (10);+ translate ([22,0]) circle (10);+ translate ([0,22]) circle (10);+ translate ([-22,0]) circle (10);+ translate ([0,-22]) circle (10);+ }+}
+ Examples/example7.escad view
@@ -0,0 +1,10 @@+// example7.escad -- A twisted rounded extrusion of the rounded union of 5 circles.+linear_extrude (height = 40, center=true, twist=90, r=5){+ union ( r = 8) {+ circle (10);+ translate ([22,0]) circle (10);+ translate ([0,22]) circle (10);+ translate ([-22,0]) circle (10);+ translate ([0,-22]) circle (10);+ }+}
+ Examples/example8.escad view
@@ -0,0 +1,7 @@+// Example8.escad -- variable assignment in loops.+a = 5;+for (c = [1, 2, 3]) {+ echo(c);+ a = a*c;+ echo(a);+}
+ Examples/example9.escad view
@@ -0,0 +1,4 @@+// Example9.escad -- function currying.+f = max(4);+echo(f(5));+echo(max(4,5));
Graphics/Implicit.hs view
@@ -3,7 +3,7 @@ -- Released under the GNU AGPLV3+, see LICENSE -- FIXME: Required. why?-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} {- The purpose of this file is to pass on the functionality we want to be accessible to an end user who is compiling objects using
Graphics/Implicit/Definitions.hs view
@@ -1,5 +1,5 @@ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)--- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)+-- Copyright 2014 2015 2016, 2017, 2018, Julia Longtin (julial@turinglace.com) -- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com) -- Released under the GNU AGPLV3+, see LICENSE @@ -17,10 +17,12 @@ ℝ3, minℝ, ℕ,+ Fastℕ, (⋅), (⋯*), (⋯/), Polyline,+ Polytri, Triangle, NormedTriangle, TriangleMesh,@@ -72,7 +74,7 @@ ) where -import Prelude (Show, Double, Integer, Maybe, Either, show, (*), (/))+import Prelude (Show, Double, Integer, Int, Maybe, Either, show, (*), (/)) import Data.VectorSpace (Scalar, InnerSpace, (<.>)) @@ -91,14 +93,17 @@ -- for Doubles. minℝ = 0.0000000000000002 +-- Arbitrary precision integers. type ℕ = Integer +-- System integers.+type Fastℕ = Int+ -- TODO: Find a better place for this (⋅) :: InnerSpace a => a -> a -> Scalar a (⋅) = (<.>) ---- handle additional instances of Show.+-- add aditional instances to Show, for when we dump the intermediate form of an object. instance Show (ℝ -> ℝ) where show _ = "<function ℝ>" @@ -132,17 +137,20 @@ -- eg. [(0,0), (0.5,1), (1,0)] ---> /\ type Polyline = [ℝ2] --- | A triangle (a,b,c) = a triangle with vertices a, b and c+-- | A triangle in 2D space (a,b,c).+type Polytri = (ℝ2, ℝ2, ℝ2)++-- | A triangle in 3D space (a,b,c) = a triangle with vertices a, b and c type Triangle = (ℝ3, ℝ3, ℝ3) -- | A triangle ((v1,n1),(v2,n2),(v3,n3)) has vertices v1, v2, v3 -- with corresponding normals n1, n2, and n3 type NormedTriangle = ((ℝ3, ℝ3), (ℝ3, ℝ3), (ℝ3, ℝ3)) --- | A triangle mesh is a bunch of triangles :)+-- | A triangle mesh is a bunch of triangles, attempting to be a surface. type TriangleMesh = [Triangle] --- | A normed triangle mesh is a bunch of normed trianlges!!+-- | A normed triangle mesh is a mesh of normed trianlges. type NormedTriangleMesh = [NormedTriangle] -- | A 2D object@@ -237,6 +245,6 @@ -- | Rectilinear 2D set type Rectilinear2 = [Box2] --- | Rectilinear 2D set+-- | Rectilinear 3D set type Rectilinear3 = [Box3]
Graphics/Implicit/Export.hs view
@@ -14,9 +14,9 @@ import Prelude (FilePath, IO, (.), ($)) -- The types of our objects (before rendering), and the type of the resolution to render with.-import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3, ℝ, Polyline, TriangleMesh, Triangle, NormedTriangle)+import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3, ℝ, Polyline, TriangleMesh, NormedTriangleMesh) --- The functions for writing our output, as well as a type used.+-- functions for outputing a file, and one of the types. import Data.Text.Lazy (Text) import qualified Data.Text.Lazy.IO as LT (writeFile) import qualified Data.ByteString.Lazy as LBS (writeFile)@@ -28,7 +28,7 @@ import qualified Graphics.Implicit.Export.PolylineFormats as PolylineFormats (svg, hacklabLaserGCode) import qualified Graphics.Implicit.Export.TriangleMeshFormats as TriangleMeshFormats (stl, binaryStl, jsTHREE) import qualified Graphics.Implicit.Export.NormedTriangleMeshFormats as NormedTriangleMeshFormats (obj)-import qualified Graphics.Implicit.Export.SymbolicFormats as SymbolicFormats (scad3, scad2)+import qualified Graphics.Implicit.Export.SymbolicFormats as SymbolicFormats (scad2, scad3) import qualified Codec.Picture as ImageFormatCodecs (DynamicImage, savePngImage) -- Write an object using the given format function.@@ -39,7 +39,8 @@ -> obj -- ^ Object to render -> IO () -- ^ Writing Action! writeObject res format filename obj =- let aprox = formatObject res format obj+ let+ aprox = formatObject res format obj in LT.writeFile filename aprox -- Write an object using the given format writer.@@ -50,8 +51,7 @@ -> obj -- ^ Object to render -> IO () -- ^ Writing Action! writeObject' res formatWriter filename obj =- let aprox = discreteAprox res obj- in formatWriter filename aprox+ formatWriter filename (discreteAprox res obj) formatObject :: (DiscreteAproxable obj aprox) => ℝ -- ^ Resolution@@ -63,13 +63,13 @@ writeSVG :: forall obj. DiscreteAproxable obj [Polyline] => ℝ -> FilePath -> obj -> IO () writeSVG res = writeObject res PolylineFormats.svg -writeSTL :: forall obj. DiscreteAproxable obj [Triangle] => ℝ -> FilePath -> obj -> IO ()+writeSTL :: forall obj. DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO () writeSTL res = writeObject res TriangleMeshFormats.stl -writeBinSTL :: forall obj. DiscreteAproxable obj [Triangle] => ℝ -> FilePath -> obj -> IO ()+writeBinSTL :: forall obj. DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO () writeBinSTL res file obj = LBS.writeFile file $ TriangleMeshFormats.binaryStl $ discreteAprox res obj -writeOBJ :: forall obj. DiscreteAproxable obj [NormedTriangle] => ℝ -> FilePath -> obj -> IO ()+writeOBJ :: forall obj. DiscreteAproxable obj NormedTriangleMesh => ℝ -> FilePath -> obj -> IO () writeOBJ res = writeObject res NormedTriangleMeshFormats.obj writeTHREEJS :: forall obj. DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO ()
Graphics/Implicit/Export/DiscreteAproxable.hs view
@@ -8,11 +8,11 @@ -- FIXME: why is this here? {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -module Graphics.Implicit.Export.DiscreteAproxable where+module Graphics.Implicit.Export.DiscreteAproxable (DiscreteAproxable, discreteAprox) where -import Prelude(Int, (-), (/), ($), (<), map, round, (+), maximum, abs, (*), fromIntegral, max, realToFrac)+import Prelude((-), (/), ($), (<), map, round, (+), maximum, abs, (*), fromIntegral, max, realToFrac) -import Graphics.Implicit.Definitions (ℝ, ℝ2, SymbolicObj3, SymbolicObj2, Polyline, TriangleMesh, NormedTriangleMesh)+import Graphics.Implicit.Definitions (ℝ, Fastℕ, ℝ2, SymbolicObj2, SymbolicObj3, Polyline, TriangleMesh, NormedTriangleMesh) import Graphics.Implicit.ObjectUtil (getImplicit3, getImplicit2, getBox3, getBox2) @@ -35,7 +35,7 @@ discreteAprox :: ℝ -> obj -> aprox instance DiscreteAproxable SymbolicObj3 TriangleMesh where- discreteAprox res obj = symbolicGetMesh res obj+ discreteAprox = symbolicGetMesh instance DiscreteAproxable SymbolicObj3 NormedTriangleMesh where discreteAprox res obj = map (normTriangle res (getImplicit3 obj)) $ symbolicGetMesh res obj@@ -55,12 +55,12 @@ 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 :: Fastℕ -> Fastℕ -> Color pixelRenderer a b = renderScreen ((fromIntegral a :: ℝ)/w - (0.5::ℝ)) ((fromIntegral b :: ℝ)/h - (0.5 ::ℝ)) renderScreen :: ℝ -> ℝ -> Color renderScreen a b =- average $ [+ average [ traceRay (cameraRay camera ((a,b) ^+^ ( 0.25/w, 0.25/h))) 2 box scene,@@ -76,7 +76,7 @@ ] instance DiscreteAproxable SymbolicObj2 [Polyline] where- discreteAprox res obj = symbolicGetContour res obj+ discreteAprox = symbolicGetContour instance DiscreteAproxable SymbolicObj2 DynamicImage where discreteAprox _ symbObj = dynamicImage $ generateImage pixelRenderer (round w) (round h)@@ -86,12 +86,12 @@ (p1@(x1,_), p2@(_,y2)) = getBox2 symbObj (dx, dy) = p2 ^-^ p1 dxy = max dx dy- pixelRenderer :: Int -> Int -> Color+ pixelRenderer :: Fastℕ -> Fastℕ -> Color pixelRenderer mya myb = mycolor where xy a b = ((x1,y2) .-^ (dxy-dx, dy-dxy)^/2) .+^ dxy*^(a/w, -b/h) s = 0.25 :: ℝ- (a', b') = (realToFrac mya, realToFrac myb) :: (ℝ2)+ (a', b') = (realToFrac mya, realToFrac myb) :: ℝ2 mycolor = average [objColor $ xy a' b', objColor $ xy a' b', objColor $ xy (a'+s) (b'+s), objColor $ xy (a'-s) (b'-s),
Graphics/Implicit/Export/MarchingSquares.hs view
@@ -2,62 +2,59 @@ -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE -module Graphics.Implicit.Export.MarchingSquares (getContour) where+-- Allow us to use explicit foralls when writing function type declarations.+{-# LANGUAGE ExplicitForAll #-} -import Prelude(Int, Bool(True, False), ceiling, fromIntegral, (/), (+), (-), filter, map, ($), (*), (/=), (<=), (>), (.), splitAt, div, unzip, length, (++), (<), (++), head, concat, not, null, (||), Eq, Int, fst, snd)+-- export getContour, which returns as array of polylines describing the edge of a 2D object.+module Graphics.Implicit.Export.MarchingSquares (getContour) where -import Graphics.Implicit.Export.Render.HandlePolylines (reducePolyline)+import Prelude(Bool(True, False), ceiling, (/), (+), (-), filter, map, ($), (*), (/=), (<=), (>), splitAt, div, unzip, length, (++), (<), (++), head, ceiling, concat, div, max, not, null, (||), Eq, fromIntegral) -import Graphics.Implicit.Definitions (ℝ2, Polyline, Obj2, (⋯/), (⋯*))+import Graphics.Implicit.Definitions (ℕ, ℝ2, Polyline, Obj2, (⋯/), (⋯*)) --- FIXME: commented out for now, parallelism is not properly implemented.--- import Control.Parallel.Strategies (using, parList, rdeepseq) import Data.VectorSpace ((^-^), (^+^)) -both :: (a -> b) -> (a,a) -> (b,b)-both f (x,y) = (f x, f y)+import Control.Arrow((***)) --- | 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.+-- import a helper, to clean up the result we return.+import Graphics.Implicit.Export.Render.HandlePolylines (reducePolyline) +-- Each step on the Y axis is done in parallel using Control.Parallel.Strategies+import Control.Parallel.Strategies (using, rdeepseq, parBuffer)++-- apply a function to both items in the provided tuple.+both :: forall t b. (t -> b) -> (t, t) -> (b, b)+both f (x,y) = (f x, f y)++-- getContour gets a polyline describing the edge of a 2D object. getContour :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [Polyline]-getContour p1 p2 d obj =+getContour p1 p2 res obj = let+ -- How much space are we rendering?+ d = p2 ^-^ p1+ -- How many steps will we take on each axis?- n :: (Int, Int)- n = (ceiling) `both` ((p2 ^-^ p1) ⋯/ d)- nx = fst n- ny = snd n- -- Divide it up and compute the polylines- gridPos :: (Int,Int) -> (Int,Int) -> ℝ2- gridPos (nx',ny') (mx,my) =- let- p :: ℝ2- p = ( fromIntegral mx / fromIntegral nx'- , fromIntegral my / fromIntegral ny')- in- p1 ^+^ (p2 ^-^ p1) ⋯* p+ nx :: ℕ+ ny :: ℕ+ n@(nx,ny) = (ceiling) `both` (d ⋯/ res)++ -- a helper for calculating a position inside of the space.+ gridPos :: (ℕ,ℕ) -> (ℕ,ℕ) -> ℝ2+ gridPos n' m = p1 ^+^ d ⋯* ((fromIntegral `both` m) ⋯/ (fromIntegral `both` n'))++ -- compute the polylines linesOnGrid :: [[[Polyline]]]- linesOnGrid = [[getSquareLineSegs- (gridPos n (mx,my))- (gridPos n (mx+1,my+1))- 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] ] `using` parBuffer (max 1 $ fromIntegral $ div ny 32) rdeepseq+ -- Cleanup, cleanup, everybody cleanup! -- (We connect multilines, delete redundant vertices on them, etc)- multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLinesDC $ linesOnGrid+ lines = filter polylineNotNull $ map reducePolyline $ orderLinesDC linesOnGrid in- multilines-+ lines -- FIXME: Commented out, not used? {--getContour2 :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [Polyline]-getContour2 p1@(x1, y1) p2@(x2, y2) d obj =- let- -- How many steps will we take on each axis?- n@(nx,ny) = (fromIntegral . ceiling) `both` ((p2 ^-^ p1) ⋯/ d)- -- Grid mapping funcs+ -- alternate Grid mapping funcs fromGrid (mx, my) = let p = (mx/nx, my/ny) in (p1 ^+^ (p2 ^-^ p1) ⋯/ p) toGrid (x,y) = (floor $ nx*(x-x1)/(x2-x1), floor $ ny*(y-y1)/(y2-y1))@@ -71,15 +68,10 @@ linesOnGrid :: [[[Polyline]]] linesOnGrid = [[getSquareLineSegs (fromGrid (mx, my)) (fromGrid (mx+1, my+1)) preEvaledObj | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]- -- Cleanup, cleanup, everybody cleanup!- -- (We connect multilines, delete redundant vertices on them, etc)- multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLinesDC $ linesOnGrid- in- multilines -} -- | This function gives line segments to divide negative interior--- regions and positive exterior ones inside a square, based on its+-- regions and positive exterior ones inside a square, based on the -- values at its vertices. -- It is based on the linearly-interpolated marching squares algorithm. @@ -88,11 +80,13 @@ let (x,y) = (x1, y1) - -- Let's evlauate obj at a few points...+ -- Let's evlauate obj at four corners... x1y1 = obj (x1, y1) x2y1 = obj (x2, y1) x1y2 = obj (x1, y2) x2y2 = obj (x2, y2)++ -- And the center point.. c = obj ((x1+x2)/2, (y1+y2)/2) dx = x2 - x1@@ -111,17 +105,19 @@ -- ---------*---------- -- midy1 + midx1 = (x, y + dy*x1y1/(x1y1-x1y2)) midx2 = (x + dx, y + dy*x2y1/(x2y1-x2y2)) midy1 = (x + dx*x1y1/(x1y1-x2y1), y ) midy2 = (x + dx*x1y2/(x1y2-x2y2), y + dy)+ notPointLine :: Eq a => [a] -> Bool- notPointLine (p1:p2:[]) = p1 /= p2- notPointLine ([]) = False- notPointLine ([_]) = False- notPointLine (_ : (_ : (_ : _))) = False- in filter (notPointLine) $ case (x1y2 <= 0, x2y2 <= 0,- x1y1 <= 0, x2y1 <= 0) of+ notPointLine (start:stop:xs) = start /= stop || notPointLine [stop:xs]+ notPointLine [_] = False+ notPointLine [] = False++ in filter notPointLine $ case (x1y2 <= 0, x2y2 <= 0,+ x1y1 <= 0, x2y1 <= 0) of -- Yes, there's some symetries that could reduce the amount of code... -- But I don't think they're worth exploiting... (True, True,@@ -162,8 +158,7 @@ else [[midx1, midy1], [midx2, midy2]] ---- $ Functions for cleaning up the polylines+-- Functions for cleaning up the polylines -- Many have multiple implementations as efficiency experiments. -- At some point, we'll get rid of the redundant ones.... @@ -187,10 +182,10 @@ let halve :: [a] -> ([a], [a]) halve l = splitAt (div (length l) 2) l- splitOrder segs' = case (\(x,y) -> (halve x, halve y)) . unzip . map (halve) $ segs' of+ splitOrder segs' = case (halve *** halve) $ unzip $ map halve $ segs' of ((a,b),(c,d)) -> orderLinesDC a ++ orderLinesDC b ++ orderLinesDC c ++ orderLinesDC d in- if (length segs < 5 || length (head segs) < 5 ) then concat $ concat segs else+ if length segs < 5 || length (head segs) < 5 then concat $ concat segs else splitOrder segs {- orderLinesP :: [[[Polyline]]] -> [Polyline]
Graphics/Implicit/Export/MarchingSquaresFill.hs view
@@ -5,31 +5,41 @@ -- Allow us to use explicit foralls when writing function type declarations. {-# LANGUAGE ExplicitForAll #-} --- define getContour, which gets a polyline describe the edge of your 2D object.+-- export getContourMesh, which returns an array of triangles describing the interior of a 2D object. module Graphics.Implicit.Export.MarchingSquaresFill (getContourMesh) where -import Prelude(Bool(True, False), fromInteger, ($), (-), (+), (/), (*), (<=), (>), ceiling, concat)+import Prelude(Bool(True, False), fromIntegral, ($), (-), (+), (/), (*), (<=), (>), ceiling, concat, max, div) -import Graphics.Implicit.Definitions (ℝ, ℝ2, Obj2)+import Graphics.Implicit.Definitions (ℕ, ℝ2, Polytri, Obj2, (⋯/), (⋯*)) --- FIXME: commented out, test how to apply..--- import Control.Parallel (par, pseq)+import Data.VectorSpace ((^-^),(^+^)) -getContourMesh :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [(ℝ2,ℝ2,ℝ2)]-getContourMesh (x1, y1) (x2, y2) (dx, dy) obj =+-- Each step on the Y axis is done in parallel using Control.Parallel.Strategies+import Control.Parallel.Strategies (using, rdeepseq, parBuffer)++-- apply a function to both items in the provided tuple.+both :: forall t b. (t -> b) -> (t, t) -> (b, b)+both f (x,y) = (f x, f y)++getContourMesh :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [Polytri]+getContourMesh p1 p2 res obj = let+ -- How much space are we rendering?+ d = p2 ^-^ p1+ -- How many steps will we take on each axis?- nx :: ℝ- nx = fromInteger $ ceiling $ (x2 - x1) / dx- ny :: ℝ- ny = fromInteger $ ceiling $ (y2 - y1) / dy- -- Divide it up and compute the polylines- trisOnGrid :: [[[(ℝ2,ℝ2,ℝ2)]]]- trisOnGrid = [[getSquareTriangles- (x1 + (x2 - x1)*mx/nx, y1 + (y2 - y1)*my/ny)- (x1 + (x2 - x1)*(mx+1)/nx, y1 + (y2 - y1)*(my+1)/ny)- obj- | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]+ nx :: ℕ+ ny :: ℕ+ n@(nx,ny) = (ceiling) `both` (d ⋯/ res)++ -- a helper for calculating a position inside of the space.+ gridPos :: (ℕ,ℕ) -> (ℕ,ℕ) -> ℝ2+ gridPos n' m = p1 ^+^ d ⋯* ((fromIntegral `both` m) ⋯/ (fromIntegral `both` n'))++ -- compute the triangles.+ trisOnGrid :: [[[Polytri]]]+ trisOnGrid = [[getSquareTriangles (gridPos n (mx,my)) (gridPos n (mx+1,my+1)) obj+ | mx <- [0.. nx-1] ] | my <- [0..ny-1] ] `using` parBuffer (max 1 $ fromIntegral $ div ny 32) rdeepseq triangles = concat $ concat trisOnGrid in triangles@@ -39,16 +49,18 @@ -- values at its vertices. -- It is based on the linearly-interpolated marching squares algorithm. -getSquareTriangles :: ℝ2 -> ℝ2 -> Obj2 -> [(ℝ2,ℝ2,ℝ2)]+getSquareTriangles :: ℝ2 -> ℝ2 -> Obj2 -> [Polytri] getSquareTriangles (x1, y1) (x2, y2) obj = let (x,y) = (x1, y1) - -- Let's evlauate obj at a few points...+ -- Let's evaluate obj at four corners... x1y1 = obj (x1, y1) x2y1 = obj (x2, y1) x1y2 = obj (x1, y2) x2y2 = obj (x2, y2)++ -- And the center point.. c = obj ((x1+x2)/2, (y1+y2)/2) dx = x2 - x1@@ -56,16 +68,16 @@ -- linearly interpolated midpoints on the relevant axis -- midy2- -- _________*__________- -- | |- -- | |- -- | |- --midx1* * midx2- -- | |- -- | |- -- | |- -- -----------*----------- -- midy1+ -- _________*_________+ -- | |+ -- | |+ -- | |+ --midx1* * midx2+ -- | |+ -- | |+ -- | |+ -- ---------*---------+ -- midy1 midx1 = (x, y + dy*x1y1/(x1y1-x1y2)) midx2 = (x + dx, y + dy*x2y1/(x2y1-x2y2))@@ -114,7 +126,7 @@ False, False) -> [(midx2, (x2,y2), midy2)] (True, False, False, True) -> if c > 0- then [((x1,y2), midx1, midy2), ((x2,y1), midy1, midx2)]+ then [((x1,y2), midx1, midy2), ((x2,y1), midy1, midx2)] --[[midx1, midy2], [midx2, midy1]] else [] --[[midx1, midy1], [midx2, midy2]] (False, True, True, False) -> if c <= 0
Graphics/Implicit/Export/PolylineFormats.hs view
@@ -7,11 +7,11 @@ {-# LANGUAGE OverloadedStrings #-} -module Graphics.Implicit.Export.PolylineFormats where+module Graphics.Implicit.Export.PolylineFormats (svg, hacklabLaserGCode) where -import Prelude((.), ($), (-), minimum, maximum, unzip, concat, show, (++), unwords, map, mapM_, snd, compare, min, max, Ord, Num)+import Prelude((.), ($), (-), (+), (/), minimum, maximum, unzip, concat, show, (++), unwords, map, mapM_, snd, compare, min, max) -import Graphics.Implicit.Definitions (Polyline, ℝ2)+import Graphics.Implicit.Definitions (Polyline, ℝ, ℝ2) import Graphics.Implicit.Export.TextBuilderUtils (Text, Builder, mempty, toLazyText, mconcat, bf, (<>), buildTruncFloat) @@ -20,19 +20,22 @@ import Text.Blaze.Internal (stringValue) import qualified Text.Blaze.Svg11.Attributes as A -import qualified Data.List as List+import Data.List (sortBy) 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)+ where+ strokeWidth :: ℝ+ strokeWidth = 1.0+ (xmin, xmax, ymin, ymax) = (minimum xs - margin, maximum xs + margin, minimum ys - margin, maximum ys + margin)+ where margin = strokeWidth / 2+ (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 $ unwords . map show $ [0,0,xmax-xmin,ymax-ymin])- $ content+ svg11 = docTypeSvg ! A.version "1.1"+ ! A.width (stringValue $ show (xmax-xmin) ++ "mm")+ ! A.height (stringValue $ show (ymax-ymin) ++ "mm")+ ! A.viewbox (stringValue $ unwords . map show $ [0,0,xmax-xmin,ymax-ymin])+ -- The reason this isn't totally straightforwards is that svg has different coordinate system -- and we need to compute the requisite translation. svg' [] = mempty @@ -43,21 +46,22 @@ 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+ thinBlueGroup = g ! A.stroke "rgb(0,0,255)" ! A.strokeWidth (stringValue $ show strokeWidth) ! A.fill "none" -- obj hacklabLaserGCode :: [Polyline] -> Text hacklabLaserGCode polylines = toLazyText $ gcodeHeader <> mconcat (map interpretPolyline orderedPolylines) <> gcodeFooter- where + where+ orderedPolylines :: [Polyline] orderedPolylines =- snd . unzip - . List.sortBy (\(a,_) (b, _) -> compare a b)+ map snd+ . sortBy (\(a,_) (b, _) -> compare a b) . map (\x -> (polylineRadius x, x)) $ polylines- polylineRadius :: forall t. (Ord t, Num t) => [(t, t)] -> t+ polylineRadius :: [ℝ2] -> ℝ polylineRadius [] = 0 polylineRadius polyline' = max (xmax' - xmin') (ymax' - ymin') where ((xmin', xmax'), (ymin', ymax')) = polylineRadius' polyline'- polylineRadius' :: forall a a1. (Ord a1, Ord a, Num a1, Num a) => [(a, a1)] -> ((a, a), (a1, a1))+ polylineRadius' :: [ℝ2] -> (ℝ2, ℝ2) polylineRadius' [] = ((0,0),(0,0)) polylineRadius' [(x,y)] = ((x,x),(y,y)) polylineRadius' ((x,y):ps) = ((min x xmin,max x xmax),(min y ymin, max y ymax))@@ -77,7 +81,6 @@ ,"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"
Graphics/Implicit/Export/RayTrace.hs view
@@ -8,13 +8,14 @@ -- FIXME: why are these needed? {-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts #-} -module Graphics.Implicit.Export.RayTrace where+module Graphics.Implicit.Export.RayTrace( dynamicImage, Color, average, Camera(Camera), Light(Light), Scene(Scene), traceRay, cameraRay) where -import Prelude(Show, RealFrac, Maybe(Just, Nothing), Int, Bool(False, True), (-), (.), ($), (*), (/), min, fromInteger, max, round, fromIntegral, unzip, map, length, sum, maximum, minimum, (>), (+), (<), (==), pred, flip, (++), not, abs, floor, fromIntegral, toRational)+import Prelude(Show, RealFrac, Maybe(Just, Nothing), Bool(False, True), (-), (.), ($), (*), (/), min, fromInteger, max, round, fromIntegral, unzip, map, length, sum, maximum, minimum, (>), (+), (<), (==), pred, flip, not, abs, floor, fromIntegral, toRational, otherwise) -import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, (⋅), Obj3)+import Graphics.Implicit.Definitions (ℝ, ℕ, ℝ2, ℝ3, (⋅), Obj3) import Codec.Picture (Pixel8, Image, DynamicImage(ImageRGBA8), PixelRGBA8(PixelRGBA8)) import Control.Monad (guard, return)+import Control.Arrow ((***)) import Data.VectorSpace (Scalar, magnitude, (^+^), (*^), normalized, (^-^), InnerSpace) import Data.Cross (cross3) @@ -34,7 +35,7 @@ type Color = PixelRGBA8 color :: Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8-color r g b a = PixelRGBA8 r g b a+color = PixelRGBA8 dynamicImage :: Image PixelRGBA8 -> DynamicImage dynamicImage = ImageRGBA8@@ -55,7 +56,7 @@ average :: [Color] -> Color average l = let - ((rs, gs), (bs, as)) = (\(a'',b'') -> (unzip a'', unzip b'')) $ unzip $ map+ ((rs, gs), (bs, as)) = (unzip *** unzip) . unzip $ map (\(PixelRGBA8 r g b a) -> ((fromIntegral r, fromIntegral g), (fromIntegral b, fromIntegral a))) l :: (([ℝ], [ℝ]), ([ℝ],[ℝ])) n = fromIntegral $ length l :: ℝ@@ -96,10 +97,9 @@ 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 :: ℝ)+ step | aval/(4::ℝ) > res = res+ | aval/(2::ℝ) > res = res/(2 :: ℝ)+ | otherwise = res/(10 :: ℝ) a' = a + step a'val = obj (p ^+^ a'*^v) in if a'val < 0@@ -118,7 +118,7 @@ then refine' 10 (a, b) (aval, bval) obj else refine' 10 (b, a) (aval, bval) obj -refine' :: Int -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ+refine' :: ℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ refine' 0 (a, _) _ _ = a refine' n (a, b) (aval, bval) obj = let@@ -143,7 +143,7 @@ let (a,b) = rayBounds ray box in case intersection ray ((a, obj (cameraP ^+^ a*^cameraV)), b) step obj of- Just p -> flip colorMult objColor $ floor (sum $ [0.2] ++ do+ Just p -> flip colorMult objColor $ floor (sum $ 0.2 : do Light lightPos lightIntensity <- lights let ray'@(Ray _ v) = rayFromTo p lightPos@@ -154,19 +154,19 @@ 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'+ normal = normalized deriv+ unitV = normalized v' proj :: forall v. InnerSpace v => v -> v -> v proj a' b' = (a'⋅b')*^b' dist = vectorDistance p lightPos- illumination = (max 0 (normal ⋅ unitV)) * lightIntensity * (25 /dist)+ 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)*(abs $ rV ⋅ cameraV))+ return $ illumination*(3 + 0.3*abs(rV ⋅ cameraV)*abs(rV ⋅ cameraV)) ) Nothing -> defaultColor
Graphics/Implicit/Export/Render.hs view
@@ -8,11 +8,12 @@ -- Allow us to use the tearser parallel list comprehension syntax, to avoid having to call zip in the complicated comprehensions below. {-# LANGUAGE ParallelListComp #-} -module Graphics.Implicit.Export.Render where+-- export getContour and getMesh, which returns the edge of a 2D object, or the surface of a 3D object, respectively.+module Graphics.Implicit.Export.Render (getMesh, getContour) where -import Prelude(Float, Bool, ceiling, ($), (/), fromIntegral, (+), (*), fromInteger, max, div, tail, map, concat, realToFrac, (==), (||), filter, not, reverse, (.), Integral, Eq, Integer, concatMap)+import Prelude(Float, Bool, ceiling, ($), fromIntegral, (+), (*), max, div, tail, map, concat, realToFrac, (==), (||), filter, not, reverse, (.), Eq, concatMap) -import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, Obj2, Obj3, TriangleMesh, Triangle, Polyline)+import Graphics.Implicit.Definitions (ℝ, ℕ, ℝ2, ℝ3, TriangleMesh, Obj2, Obj3, Triangle, Polyline, (⋯/)) import Data.VectorSpace ((^-^)) @@ -41,7 +42,7 @@ -- Success: This is our mesh. --- Each step is done in parallel using Control.Parallel.Strategies+-- Each step on the Z axis is done in parallel using Control.Parallel.Strategies import Control.Parallel.Strategies (using, rdeepseq, parBuffer) import Control.DeepSeq (NFData)@@ -66,38 +67,39 @@ -- For the 2D case, we need one last thing, cleanLoopsFromSegs: import Graphics.Implicit.Export.Render.HandlePolylines (cleanLoopsFromSegs) +-- apply a function to all three items in the provided tuple.+allthree :: forall t b. (t -> b) -> (t, t, t) -> (b, b, b)+allthree f (x,y,z) = (f x, f y, f z)++-- FIXME: res should be ℝ3, not ℝ. getMesh :: ℝ3 -> ℝ3 -> ℝ -> Obj3 -> TriangleMesh getMesh p1@(x1,y1,z1) p2 res obj = let -- How much space are we rendering?- (dx,dy,dz) = p2 ^-^ p1+ d = p2 ^-^ p1 -- How many steps will we take on each axis?- nx :: Integral a => a- nx = ceiling $ dx / res- ny :: Integral a => a- ny = ceiling $ dy / res- nz :: Integral a => a- nz = ceiling $ dz / res+ nx :: ℕ+ ny :: ℕ+ nz :: ℕ+ (nx,ny,nz) = ceiling `allthree` ( d ⋯/ (res,res,res)) -- How big are the steps?- rx = dx / fromInteger nx- ry = dy / fromInteger ny- rz = dz / fromInteger nz+ (rx,ry,rz) = d ⋯/ (fromIntegral `allthree` (nx,ny,nz)) -- The positions we're rendering.- pXs = [ x1 + rx*n | n <- [0.. fromInteger nx] ]- pYs = [ y1 + ry*n | n <- [0.. fromInteger ny] ]- pZs = [ z1 + rz*n | n <- [0.. fromInteger nz] ]+ pXs = [ x1 + rx*n | n <- [0.. fromIntegral nx] ]+ pYs = [ y1 + ry*n | n <- [0.. fromIntegral ny] ]+ pZs = [ z1 + rz*n | n <- [0.. fromIntegral nz] ] - par3DList :: forall t. NFData t => Integer -> Integer -> Integer -> ((Integer -> ℝ) -> Integer -> (Integer -> ℝ) -> Integer -> (Integer -> ℝ) -> Integer -> t) -> [[[t]]]+ par3DList :: forall t. NFData t => ℕ -> ℕ -> ℕ -> ((ℕ -> ℝ) -> ℕ -> (ℕ -> ℝ) -> ℕ -> (ℕ -> ℝ) -> ℕ -> t) -> [[[t]]] par3DList lenx leny lenz f = [[[f- (\n -> x1 + rx*fromInteger (mx+n)) mx- (\n -> y1 + ry*fromInteger (my+n)) my- (\n -> z1 + rz*fromInteger (mz+n)) mz+ (\n -> x1 + rx*fromIntegral (mx+n)) mx+ (\n -> y1 + ry*fromIntegral (my+n)) my+ (\n -> z1 + rz*fromIntegral (mz+n)) mz | mx <- [0..lenx] ] | my <- [0..leny] ] | mz <- [0..lenz] ]- `using` (parBuffer (max 1 . fromInteger $ div lenz 32) rdeepseq)+ `using` parBuffer (max 1 . fromIntegral $ div lenz 32) rdeepseq -- Evaluate obj to avoid waste in mids, segs, later. objV = par3DList (nx+2) (ny+2) (nz+2) $ \x _ y _ z _ -> obj (x 0, y 0, z 0)@@ -108,21 +110,21 @@ | x0 <- pXs | objX0Y0Z0 <- objY0Z0 | objX0Y0Z1 <- objY0Z1 ]| y0 <- pYs | objY0Z0 <- objZ0 | objY0Z1 <- objZ1 ]| z0 <- pZs | z1' <- tail pZs | objZ0 <- objV | objZ1 <- tail objV- ] `using` (parBuffer (max 1 . fromInteger $ div nz 32) rdeepseq)+ ] `using` parBuffer (max 1 . fromIntegral $ div nz 32) rdeepseq midsY = [[[ interpolate (y0, objX0Y0Z0) (y1', objX0Y1Z0) (appAC obj x0 z0) res | x0 <- pXs | objX0Y0Z0 <- objY0Z0 | objX0Y1Z0 <- objY1Z0 ]| y0 <- pYs | y1' <- tail pYs | objY0Z0 <- objZ0 | objY1Z0 <- tail objZ0 ]| z0 <- pZs | objZ0 <- objV- ] `using` (parBuffer (max 1 $ fromInteger $ div nz 32) rdeepseq)+ ] `using` parBuffer (max 1 $ fromIntegral $ div ny 32) rdeepseq midsX = [[[ interpolate (x0, objX0Y0Z0) (x1', objX1Y0Z0) (appBC obj y0 z0) res | x0 <- pXs | x1' <- tail pXs | objX0Y0Z0 <- objY0Z0 | objX1Y0Z0 <- tail objY0Z0 ]| y0 <- pYs | objY0Z0 <- objZ0 ]| z0 <- pZs | objZ0 <- objV- ] `using` (parBuffer (max 1 $ fromInteger $ div nz 32) rdeepseq)+ ] `using` parBuffer (max 1 $ fromIntegral $ div nx 32) rdeepseq -- Calculate segments for each side segsZ = [[[@@ -135,7 +137,7 @@ |objY0Z0 <- objZ0 | objY1Z0 <- tail objZ0 ]|z0<-pZs |mX' <-midsX| mY' <-midsY |objZ0 <- objV- ] `using` (parBuffer (max 1 $ fromInteger $ div nz 32) rdeepseq)+ ] `using` parBuffer (max 1 $ fromIntegral $ div nz 32) rdeepseq segsY = [[[ map2 (inj2 y0) $ getSegs (x0,z0) (x1',z1') (obj *$* y0)@@ -147,7 +149,7 @@ |objY0Z0 <- objZ0 | objY0Z1 <- objZ1 ]|z0<-pZs|z1'<-tail pZs|mB' <-midsX|mBT <-tail midsX|mA' <-midsZ |objZ0 <- objV | objZ1 <- tail objV- ] `using` (parBuffer (max 1 $ fromInteger $ div nz 32) rdeepseq)+ ] `using` parBuffer (max 1 $ fromIntegral $ div ny 32) rdeepseq segsX = [[[ map2 (inj1 x0) $ getSegs (y0,z0) (y1',z1') (obj $** x0)@@ -159,7 +161,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` (parBuffer (max 1 $ fromInteger $ div nz 32) rdeepseq)+ ] `using` parBuffer (max 1 $ fromIntegral $ div nx 32) rdeepseq -- (3) & (4) : get and tesselate loops sqTris = [[[@@ -183,9 +185,11 @@ ]| segZ' <- segsZ | segZT <- tail segsZ | segY' <- segsY | segX' <- segsX- ] `using` (parBuffer (max 1 $ fromInteger $ div nz 32) rdeepseq)+ ] `using` parBuffer (max 1 $ fromIntegral $ div nz 32) rdeepseq - in cleanupTris $ mergedSquareTris $ concat $ concat $ concat sqTris -- (5) merge squares, etc+ in+ -- (5) merge squares, etc+ cleanupTris . mergedSquareTris . concat . concat $ concat sqTris -- Removes triangles that are empty, when converting their positions to Float resolution. -- NOTE: this will need to be disabled for AMF, and other triangle formats that can handle Double.@@ -202,30 +206,36 @@ isDegenerateTri (a, b, c) = isDegenerateTriFloat (floatPoint a, floatPoint b, floatPoint c) in filter (not . isDegenerateTri) tris +-- apply a function to both items in the provided tuple.+both :: forall t b. (t -> b) -> (t, t) -> (b, b)+both f (x,y) = (f x, f y)++-- getContour gets a polyline describing the edge of a 2D object. getContour :: ℝ2 -> ℝ2 -> ℝ -> Obj2 -> [Polyline] getContour p1@(x1, y1) p2 res obj = let- (dx,dy) = p2 ^-^ p1+ -- the size of the region we're being asked to search.+ d = p2 ^-^ p1 -- How many steps will we take on each axis?- nx :: Integral a => a- nx = ceiling $ dx / res- ny :: Integral a => a- ny = ceiling $ dy / res+ nx :: ℕ+ ny :: ℕ+ (nx,ny) = (ceiling) `both` (d ⋯/ (res,res)) - rx = dx/fromInteger nx- ry = dy/fromInteger ny+ -- How big are the steps?+ (rx,ry) = d ⋯/ (fromIntegral `both` (nx,ny)) - pYs = [ y1 + ry*n | n <- [0.. fromInteger ny] ]- pXs = [ x1 + rx*n | n <- [0.. fromInteger nx] ]+ -- the points inside of the region.+ pYs = [ y1 + ry*(fromIntegral p) | p <- [0.. ny] ]+ pXs = [ x1 + rx*(fromIntegral p) | p <- [0.. nx] ] - par2DList :: forall t. NFData t => Integer -> Integer -> ((Integer -> ℝ) -> Integer -> (Integer -> ℝ) -> Integer -> t) -> [[t]]+ par2DList :: forall t. NFData t => ℕ -> ℕ -> ((ℕ -> ℝ) -> ℕ -> (ℕ -> ℝ) -> ℕ -> t) -> [[t]] 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` (parBuffer (max 1 $ fromInteger $ div leny 32) rdeepseq)+ `using` parBuffer (max 1 . fromIntegral $ div leny 32) rdeepseq -- Evaluate obj to avoid waste in mids, segs, later.@@ -238,13 +248,13 @@ 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` (parBuffer (max 1 $ fromInteger $ div ny 32) rdeepseq)+ ] `using` parBuffer (max 1 . fromIntegral $ 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` (parBuffer (max 1 $ fromInteger $ div ny 32) rdeepseq)+ ] `using` parBuffer (max 1 . fromIntegral $ div nx 32) rdeepseq -- Calculate segments for each side @@ -256,12 +266,10 @@ |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` (parBuffer (max 1 $ fromInteger $ div ny 32) rdeepseq)-- in cleanLoopsFromSegs $ concat $ concat $ segs -- (5) merge squares, etc--+ ] `using` parBuffer (max 1 . fromIntegral $ div ny 32) rdeepseq + in+ cleanLoopsFromSegs . concat $ concat segs -- (5) merge squares, etc -- utility functions @@ -291,16 +299,17 @@ f **$ c = \(a,b) -> f (a,b,c) appAB :: forall t t1 t2 t3. ((t1, t2, t3) -> t) -> t1 -> t2 -> t3 -> t-appAB f a b = \c -> f (a,b,c)+appAB f a b c = f (a,b,c) appBC :: forall t t1 t2 t3. ((t1, t2, t3) -> t) -> t2 -> t3 -> t1 -> t-appBC f b c = \a -> f (a,b,c)+appBC f b c a = f (a,b,c) appAC :: forall t t1 t2 t3. ((t1, t2, t3) -> t) -> t1 -> t3 -> t2 -> t-appAC f a c = \b -> f (a,b,c)+appAC f a c b = f (a,b,c) map2 :: forall a b. (a -> b) -> [[a]] -> [[b]] map2 f = map (map f)-map2R :: forall a a1. (a1 -> a) -> [[a1]] -> [[a]]-map2R f = map (reverse . map f)+-- FIXME: not used?+--map2R :: forall a a1. (a1 -> a) -> [[a1]] -> [[a]]+--map2R f = map (reverse . map f) mapR :: forall a. [[a]] -> [[a]] mapR = map reverse
Graphics/Implicit/Export/Render/Definitions.hs view
@@ -1,25 +1,20 @@ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) -- Released under the GNU AGPLV3+, see LICENSE +-- We want a type that can represent squares/quads and triangles. module Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq)) where import Prelude() -import Graphics.Implicit.Definitions(ℝ, ℝ2, ℝ3, Triangle)+import Graphics.Implicit.Definitions(ℝ, ℝ2, ℝ3, TriangleMesh) import Control.DeepSeq (NFData, rnf) --- 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]+ | Tris TriangleMesh --- For use with Parallel.Strategies later+-- FIXME: 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
@@ -8,8 +8,9 @@ module Graphics.Implicit.Export.Render.GetLoops (getLoops) where -- Explicitly include what we want from Prelude.-import Prelude (Eq, head, last, tail, (==), Bool(False), filter, not, (.), null, error, (++))+import Prelude (Eq, head, last, tail, (==), Bool(False), (.), null, error, (++)) +import Data.List (partition) -- The goal of getLoops is to extract loops from a list of segments. -- The input is a list of segments.@@ -51,7 +52,7 @@ 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.+-- In this case, we return it and start searching for another loop. getLoops' segs workingLoop | head (head workingLoop) == last (last workingLoop) = workingLoop : getLoops' segs []@@ -60,16 +61,14 @@ -- and stick one on if we find it. -- Otherwise... something is really screwed up. --- FIXME: connects should be used with a singleton.- getLoops' segs workingLoop = let presEnd :: forall c. [[c]] -> c presEnd = last . last connects (x:_) = x == presEnd workingLoop connects [] = False -- Handle the empty case.- possibleConts = filter connects segs- nonConts = filter (not . connects) segs+ -- divide our set into sequences that connect, and sequences that don't.+ (possibleConts,nonConts) = partition connects segs (next, unused) = if null possibleConts then error "unclosed loop in paths given" else (head possibleConts, tail possibleConts ++ nonConts)
Graphics/Implicit/Export/Render/GetSegs.hs view
@@ -74,7 +74,7 @@ midy2 = (midy2V, y + dy) notPointLine :: Eq a => [a] -> Bool- notPointLine (np1:np2:[]) = np1 /= np2+ notPointLine [np1, np2] = np1 /= np2 notPointLine [] = False notPointLine [_] = False notPointLine (_ : (_ : (_ : _))) = False@@ -82,8 +82,8 @@ -- takes straight lines between mid points and subdivides them to -- account for sharp corners, etc. - in map (refine res obj) . filter (notPointLine) $ case (x1y2 <= 0, x2y2 <= 0,- x1y1 <= 0, x2y1 <= 0) of+ in map (refine res obj) . filter notPointLine $ case (x1y2 <= 0, x2y2 <= 0,+ x1y1 <= 0, x2y1 <= 0) of -- An important point here is orientation. If you imagine going along a -- generated segment, the interior should be on the left-hand side.
Graphics/Implicit/Export/Render/HandlePolylines.hs view
@@ -7,7 +7,7 @@ module Graphics.Implicit.Export.Render.HandlePolylines (cleanLoopsFromSegs, reducePolyline) where -import Prelude(Bool(False), Maybe(Just, Nothing), map, (.), filter, (==), last, reverse, ($), (++), tail, (-), (/), abs, (<=), (||), (&&), (*), (>), not, null)+import Prelude(Bool(False), Maybe(Just, Nothing), map, (.), filter, (==), last, reverse, ($), (++), tail, (-), (/), abs, (<=), (||), (&&), (*), (>), not, null, otherwise) import Graphics.Implicit.Definitions (minℝ, Polyline, ℝ) @@ -21,23 +21,24 @@ 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 ((p3:ps):segs)+ | p3 == last present = (Just (p3:ps), segs)+ | last ps == last present = (Just (reverse $ p3:ps), segs)+ | otherwise = case findNext segs of (res1,res2) -> (res1,(p3:ps):res2) findNext [] = (Nothing, [])- findNext (([]):_) = (Nothing, [])+ findNext ([]:_) = (Nothing, []) in case findNext remaining of- (Nothing, _) -> present:(joinSegs remaining)+ (Nothing, _) -> present: joinSegs remaining (Just match, others) -> joinSegs $ (present ++ tail match): others reducePolyline :: [(ℝ, ℝ)] -> [(ℝ, ℝ)]-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) ) <= minℝ- || ( (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):(x3,y3):others)+ | (x1,y1) == (x2,y2) = reducePolyline ((x2,y2):(x3,y3):others)+ | abs ( (y2-y1)/(x2-x1) - (y3-y1)/(x3-x1) ) <= minℝ+ || ( (x2-x1) == 0 && (x3-x1) == 0 && (y2-y1)*(y3-y1) > 0) =+ reducePolyline ((x1,y1):(x3,y3):others)+ | otherwise = (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
Graphics/Implicit/Export/Render/HandleSquares.hs view
@@ -6,7 +6,7 @@ import Prelude(concatMap, (++)) -import Graphics.Implicit.Definitions (Triangle)+import Graphics.Implicit.Definitions (TriangleMesh) import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq)) import Data.VectorSpace ((^*), (*^), (^+^)) @@ -57,7 +57,7 @@ -} -mergedSquareTris :: [TriSquare] -> [Triangle]+mergedSquareTris :: [TriSquare] -> TriangleMesh mergedSquareTris sqTris = let -- We don't need to do any work on triangles. They'll just be part of@@ -66,7 +66,7 @@ triTriangles = [tri | Tris tris <- sqTris, tri <- tris ] --concat $ map (\(Tris a) -> a) $ filter isTris sqTris -- We actually want to work on the quads, so we find those- squaresFromTris = [ (Sq x y z q) | Sq x y z q <- sqTris ]+ squaresFromTris = [ Sq x y z q | Sq x y z q <- sqTris ] {- -- Collect ones that are on the same plane. planeAligned = groupWith (\(Sq basis z _ _) -> (basis,z)) squares@@ -126,7 +126,7 @@ -} -- Reconstruct a triangle-squareToTri :: TriSquare -> [Triangle]+squareToTri :: TriSquare -> TriangleMesh squareToTri (Sq (b1,b2,b3) z (x1,x2) (y1,y2)) = let zV = b3 ^* z
Graphics/Implicit/Export/Render/Interpolate.hs view
@@ -7,9 +7,9 @@ module Graphics.Implicit.Export.Render.Interpolate (interpolate) where -import Prelude(Integer, (*), (>), (<), (/=), (+), (-), (/), (==), (&&), abs)+import Prelude((*), (>), (<), (/=), (+), (-), (/), (==), (&&), abs) -import Graphics.Implicit.Definitions (ℝ, ℝ2)+import Graphics.Implicit.Definitions (ℝ, ℕ, ℝ2) -- Consider a function f(x): @@ -43,6 +43,8 @@ -- If it doesn't cross zero, we don't actually care what answer we give, -- just that it's cheap. +-- FIXME: accept resolution on multiple axises.+ interpolate :: ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ -> ℝ interpolate (a,aval) (_,bval) _ _ | aval*bval > 0 = a @@ -89,38 +91,38 @@ -- 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+ interpolateBin 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+ then interpolateBin 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+ else interpolateBin 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+ interpolateLin 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+ then interpolateLin 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+ else interpolateLin 0 (a',a'val) (b',b'val) f -} interpolate (a,aval) (b,bval) f _ =- -- Make sure aval > bval, then pass to interpolate_lin+ -- Make sure aval > bval, then pass to interpolateLin if aval > bval- then interpolate_lin 0 (a,aval) (b,bval) f- else interpolate_lin 0 (b,bval) (a,aval) f+ then interpolateLin 0 (a,aval) (b,bval) f+ else interpolateLin 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 :: Integer -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ-interpolate_lin n (a, aval) (b, bval) obj | aval /= bval=+interpolateLin :: ℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ+interpolateLin n (a, aval) (b, bval) obj | aval /= bval= let -- Interpolate and evaluate mid :: ℝ@@ -144,32 +146,32 @@ -- 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+ then interpolateLin (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+ else interpolateBin (n+1) (a', a'val) (b', b'val) obj -- And a fallback:-interpolate_lin _ (a, _) _ _ = a+interpolateLin _ (a, _) _ _ = a -- Now for binary searching!-interpolate_bin :: Integer -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ+interpolateBin :: ℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ -- The termination case: -interpolate_bin 5 (a,aval) (b,bval) _ =+interpolateBin 5 (a,aval) (b,bval) _ = if abs aval < abs bval then a else b -- Otherwise, have fun with mid! -interpolate_bin n (a,aval) (b,bval) f =+interpolateBin n (a,aval) (b,bval) f = let mid :: ℝ 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 interpolateBin (n+1) (mid,midval) (b,bval) f+ else interpolateBin (n+1) (a,aval) (mid,midval) f
Graphics/Implicit/Export/Render/RefineSegs.hs view
@@ -2,11 +2,12 @@ -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE +-- export one function, which refines polylines. module Graphics.Implicit.Export.Render.RefineSegs (refine) where -import Prelude(Int, (<), (/), (++), (*), ($), (&&), (-), (+), (.), (>), abs, tail, sqrt, (<=))+import Prelude((<), (/), (++), (*), ($), (&&), (-), (+), (.), (>), abs, tail, sqrt, (<=)) -import Graphics.Implicit.Definitions (ℝ, ℝ2, minℝ, Obj2, (⋅))+import Graphics.Implicit.Definitions (ℝ, ℝ2, minℝ, ℕ, Obj2, (⋅)) import Graphics.Implicit.Export.Util (centroid) import Data.VectorSpace (normalized, magnitude, (^-^), (^*), (^+^))@@ -30,7 +31,7 @@ -- detail adds new points to a polyline to add more detail. -detail :: Int -> ℝ -> (ℝ2 -> ℝ) -> [ℝ2] -> [ℝ2]+detail :: ℕ -> ℝ -> (ℝ2 -> ℝ) -> [ℝ2] -> [ℝ2] detail n res obj [p1, p2] | n < 2 = let mid = centroid [p1,p2]
Graphics/Implicit/Export/Render/TesselateLoops.hs view
@@ -4,11 +4,16 @@ module Graphics.Implicit.Export.Render.TesselateLoops (tesselateLoop) where -import Prelude(Int, return, ($), length, (==), zip, init, tail, reverse, (<), (/), null, foldl1, (++), head, (*), abs, (>), (&&), (+), concatMap)-import Graphics.Implicit.Definitions (ℝ, Obj3, ℝ3, Triangle, (⋅))+import Prelude(return, ($), length, (==), zip, init, tail, reverse, (<), (/), null, foldl1, (++), head, (*), abs, (>), (&&), (+), concatMap)++import Graphics.Implicit.Definitions (ℝ, Fastℕ, Obj3, ℝ3, TriangleMesh, (⋅))+ import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq))+ import Graphics.Implicit.Export.Util (centroid)+ import Data.VectorSpace (normalized, (^-^), (^+^), magnitude, (^/), (^*))+ import Data.Cross (cross3) tesselateLoop :: ℝ -> Obj3 -> [[ℝ3]] -> [TriSquare]@@ -27,12 +32,12 @@ -} tesselateLoop res obj [[_,_], as@(_:_:_:_),[_,_], bs@(_:_:_:_)] | length as == length bs =- concatMap (tesselateLoop res obj) $+ concatMap (tesselateLoop res obj) [[[a1,b1],[b1,b2],[b2,a2],[a2,a1]] | ((a1,b1),(a2,b2)) <- zip (init pairs) (tail pairs)] where pairs = zip (reverse as) bs tesselateLoop res obj [as@(_:_:_:_),[_,_], bs@(_:_:_:_), [_,_] ] | length as == length bs =- concatMap (tesselateLoop res obj) $+ concatMap (tesselateLoop res obj) [[[a1,b1],[b1,b2],[b2,a2],[a2,a1]] | ((a1,b1),(a2,b2)) <- zip (init pairs) (tail pairs)] where pairs = zip (reverse as) bs @@ -58,7 +63,7 @@ -} tesselateLoop res obj [[a,_],[b,_],[c,_],[d,_]] | obj (centroid [a,c]) < res/30 =- return $ Tris $ [(a,b,c),(a,c,d)]+ return $ Tris [(a,b,c),(a,c,d)] -- Fallback case: make fans @@ -71,7 +76,7 @@ else let mid@(_,_,_) = centroid path midval = obj mid- preNormal = foldl1 (^+^) $+ preNormal = foldl1 (^+^) [ a `cross3` b | (a,b) <- zip path (tail path ++ [head path]) ] preNormalNorm = magnitude preNormal normal = preNormal ^/ preNormalNorm@@ -83,7 +88,7 @@ else early_tris ++ [(a,b,mid) | (a,b) <- zip path (tail path ++ [head path]) ] -shrinkLoop :: Int -> [ℝ3] -> ℝ -> Obj3 -> ([Triangle], [ℝ3])+shrinkLoop :: Fastℕ -> [ℝ3] -> ℝ -> Obj3 -> (TriangleMesh, [ℝ3]) shrinkLoop _ path@[a,b,c] res obj = if abs (obj $ centroid [a,b,c]) < res/50
+ Graphics/Implicit/Export/Symbolic/CoerceSymbolic2.hs view
@@ -0,0 +1,29 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Copyright (C) 2016, Julia Longtin (julial@turinglace.com)+-- Released under the GNU AGPLV3+, see LICENSE++{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}++module Graphics.Implicit.Export.Symbolic.CoerceSymbolic2 (coerceSymbolic2) where++import Graphics.Implicit.Definitions+import Graphics.Implicit.Export.DiscreteAproxable++import Graphics.Implicit.Operations+import Graphics.Implicit.Primitives++coerceSymbolic2 :: SymbolicObj2 -> BoxedObj2+coerceSymbolic2 (EmbedBoxedObj2 boxedObj) = boxedObj+coerceSymbolic2 (RectR r a b) = rectR r a b+coerceSymbolic2 (Circle r ) = circle r+coerceSymbolic2 (PolygonR r points) = polygonR r points+coerceSymbolic2 (UnionR2 r objs) = unionR r (map coerceSymbolic2 objs)+coerceSymbolic2 (IntersectR2 r objs) = intersectR r (map coerceSymbolic2 objs)+coerceSymbolic2 (DifferenceR2 r objs) = differenceR r (map coerceSymbolic2 objs)+coerceSymbolic2 (Complement2 obj) = complement $ coerceSymbolic2 obj+coerceSymbolic2 (Shell2 w obj) = shell w $ coerceSymbolic2 obj+coerceSymbolic2 (Translate2 v obj) = translate v $ coerceSymbolic2 obj+coerceSymbolic2 (Scale2 s obj) = scale s $ coerceSymbolic2 obj+coerceSymbolic2 (Rotate2 a obj) = rotateXY a $ coerceSymbolic2 obj+coerceSymbolic2 (Outset2 d obj) = outset 2 $ coerceSymbolic2 obj+
+ Graphics/Implicit/Export/Symbolic/CoerceSymbolic3.hs view
@@ -0,0 +1,35 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Copyright (C) 2016, Julia Longtin (julial@turinglace.com)+-- Released under the GNU AGPLV3+, see LICENSE++{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}++-- We just want to export the instance...+module Graphics.Implicit.Export.Symbolic.CoerceSymbolic3 (coerceSymbolic3) where++import Graphics.Implicit.Definitions+import Graphics.Implicit.Export.DiscreteAproxable++import Graphics.Implicit.Operations+import Graphics.Implicit.Primitives++import Graphics.Implicit.Export.Symbolic.CoerceSymbolic2++coerceSymbolic3 :: SymbolicObj3 -> BoxedObj3+coerceSymbolic3 (EmbedBoxedObj3 boxedObj) = boxedObj+coerceSymbolic3 (Rect3R r a b) = rect3R r a b+coerceSymbolic3 (Sphere r ) = sphere r+coerceSymbolic3 (UnionR3 r objs) = unionR r (map coerceSymbolic3 objs)+coerceSymbolic3 (IntersectR3 r objs) = intersectR r (map coerceSymbolic3 objs)+coerceSymbolic3 (DifferenceR3 r objs) = differenceR r (map coerceSymbolic3 objs)+coerceSymbolic3 (Complement3 obj) = complement $ coerceSymbolic3 obj+coerceSymbolic3 (Shell3 w obj) = shell w $ coerceSymbolic3 obj+coerceSymbolic3 (Translate3 v obj) = translate v $ coerceSymbolic3 obj+coerceSymbolic3 (Scale3 s obj) = scale s $ coerceSymbolic3 obj+coerceSymbolic3 (Outset3 d obj) = outset d $ coerceSymbolic3 obj+coerceSymbolic3 (Rotate3 rot obj) = rotate3 rot $ coerceSymbolic3 obj+coerceSymbolic3 (Rotate3V rot axis obj) = rotate3v rot axis $ coerceSymbolic3 obj+coerceSymbolic3 (ExtrudeR r obj h) = extrudeR r (coerceSymbolic2 obj) h+coerceSymbolic3 (ExtrudeRMod r mod obj h) = extrudeRMod r mod (coerceSymbolic2 obj) h+coerceSymbolic3 (ExtrudeOnEdgeOf obj1 obj2) = extrudeOnEdgeOf (coerceSymbolic2 obj1) (coerceSymbolic2 obj2)+
Graphics/Implicit/Export/Symbolic/Rebound2.hs view
@@ -16,4 +16,4 @@ d :: ℝ2 d = (b ^-^ a) ^/ 10 in- (obj, ((a ^-^ d), (b ^+^ d)))+ (obj, (a ^-^ d, b ^+^ d))
Graphics/Implicit/Export/Symbolic/Rebound3.hs view
@@ -16,5 +16,5 @@ d :: ℝ3 d = (b ^-^ a) ^/ 10 in- (obj, ((a ^-^ d), (b ^+^ d)))+ (obj, (a ^-^ d, b ^+^ d))
Graphics/Implicit/Export/SymbolicFormats.hs view
@@ -38,7 +38,7 @@ buildArgs :: (Text, Text) -> [Builder] -> Builder buildArgs _ [] = "()"-buildArgs (c1, c2) args = "(" <> (fromLazyText c1) <> mconcat (intersperse "," args) <> (fromLazyText c2) <> ")"+buildArgs (c1, c2) args = "(" <> fromLazyText c1 <> mconcat (intersperse "," args) <> fromLazyText c2 <> ")" call :: Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder call = callToken ("[", "]")@@ -55,7 +55,7 @@ buildS3 (Sphere r) = callNaked "sphere" ["r = " <> bf r] [] -buildS3 (Cylinder h r1 r2) = call "cylinder" [+buildS3 (Cylinder h r1 r2) = callNaked "cylinder" [ "r1 = " <> bf r1 ,"r2 = " <> bf r2 , bf h@@ -75,8 +75,7 @@ buildS3 (Rotate3 (x,y,z) obj) = call "rotate" [bf (rad2deg x), bf (rad2deg y), bf (rad2deg z)] [buildS3 obj] --- FIXME: where is Rotate3V?-buildS3 (Rotate3V _ _ _) = error "Rotate3V not implemented."+buildS3 Rotate3V{} = error "Rotate3V not implemented." buildS3 (Outset3 r obj) | r == 0 = call "outset" [] [buildS3 obj] @@ -100,17 +99,17 @@ -- FIXME: where are RotateExtrude, ExtrudeOnEdgeOf? -buildS3(Rect3R _ _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."+buildS3 Rect3R{} = error "cannot provide roundness when exporting openscad; unsupported in target format." buildS3(UnionR3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format." buildS3(IntersectR3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format." buildS3(DifferenceR3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format." buildS3(Outset3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format." buildS3(Shell3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."-buildS3(ExtrudeR _ _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."-buildS3(ExtrudeRotateR _ _ _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."-buildS3(ExtrudeRM _ _ _ _ _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."+buildS3 ExtrudeR{} = error "cannot provide roundness when exporting openscad; unsupported in target format."+buildS3 ExtrudeRotateR {} = error "cannot provide roundness when exporting openscad; unsupported in target format."+buildS3 ExtrudeRM{} = error "cannot provide roundness when exporting openscad; unsupported in target format." buildS3(EmbedBoxedObj3 _) = error "cannot provide roundness when exporting openscad; unsupported in target format."-buildS3(RotateExtrude _ _ _ _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."+buildS3 RotateExtrude{} = error "cannot provide roundness when exporting openscad; unsupported in target format." buildS3(ExtrudeOnEdgeOf _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format." -- Now the 2D objects/transforms.@@ -126,7 +125,7 @@ buildS2 (PolygonR r points) | r == 0 = call "polygon" [buildVector [x,y] | (x,y) <- points] [] where buildVector comps = "[" <> mconcat (intersperse "," $ map bf comps) <> "]" -buildS2 (Complement2 obj) = call "complement" [] $ [buildS2 obj]+buildS2 (Complement2 obj) = call "complement" [] [buildS2 obj] buildS2 (UnionR2 r objs) | r == 0 = call "union" [] $ map buildS2 objs @@ -134,18 +133,18 @@ buildS2 (IntersectR2 r objs) | r == 0 = call "intersection" [] $ map buildS2 objs -buildS2 (Translate2 (x,y) obj) = call "translate" [bf x, bf y] $ [buildS2 obj]+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 (Scale2 (x,y) obj) = call "scale" [bf x, bf y] [buildS2 obj] -buildS2 (Rotate2 (r) obj) = call "rotate" [bf (rad2deg r)] $ [buildS2 obj]+buildS2 (Rotate2 r obj) = call "rotate" [bf (rad2deg r)] [buildS2 obj] -buildS2 (Outset2 r obj) | r == 0 = call "outset" [] $ [buildS2 obj]+buildS2 (Outset2 r obj) | r == 0 = call "outset" [] [buildS2 obj] -buildS2 (Shell2 r obj) | r == 0 = call "shell" [] $ [buildS2 obj]+buildS2 (Shell2 r obj) | r == 0 = call "shell" [] [buildS2 obj] -- Generate errors for rounding requests. OpenSCAD does not support rounding.-buildS2 (RectR _ _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."+buildS2 RectR{} = error "cannot provide roundness when exporting openscad; unsupported in target format." buildS2 (PolygonR _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format." buildS2 (UnionR2 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format." buildS2 (DifferenceR2 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
Graphics/Implicit/Export/SymbolicObj2.hs view
@@ -3,17 +3,17 @@ -- Released under the GNU AGPLV3+, see LICENSE -- FIXME: why is all of this needed?-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} -- This file symbolicaly renders contours and contour fillings. -- If it can't, it passes the puck to a marching-squares-like -- algorithm... -module Graphics.Implicit.Export.SymbolicObj2 where+module Graphics.Implicit.Export.SymbolicObj2 (symbolicGetOrientedContour, symbolicGetContour, symbolicGetContourMesh) where import Prelude(map, ($), (-), (/), (+), (>), (*), (.), reverse, cos, pi, sin, max, fromInteger, ceiling) -import Graphics.Implicit.Definitions (ℝ, ℝ2, SymbolicObj2(RectR, Circle, Translate2, Scale2), Polyline, (⋯*))+import Graphics.Implicit.Definitions (ℝ, SymbolicObj2(RectR, Circle, Translate2, Scale2), Polyline, Polytri, (⋯*)) import Graphics.Implicit.Export.MarchingSquaresFill (getContourMesh) @@ -52,7 +52,7 @@ (obj', (a,b)) -> Render.getContour a b res obj' -symbolicGetContourMesh :: ℝ -> SymbolicObj2 -> [(ℝ2,ℝ2,ℝ2)]+symbolicGetContourMesh :: ℝ -> SymbolicObj2 -> [Polytri] 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 (\(c,d,e) -> (c ⋯* s, d ⋯* s, e ⋯* s) ) $@@ -68,5 +68,3 @@ n = max 5 (fromInteger . ceiling $ 2*pi*r/res) symbolicGetContourMesh res obj = case rebound2 (getImplicit2 obj, getBox2 obj) of (obj', (a,b)) -> getContourMesh a b (res,res) obj'--
Graphics/Implicit/Export/SymbolicObj3.hs view
@@ -6,14 +6,14 @@ {-# LANGUAGE ExplicitForAll #-} -- FIXME: why are these needed?-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} -- The purpose of this function is to symbolicaly compute triangle meshes using the symbolic system where possible. -- Otherwise we coerce it into an implicit function and apply our modified marching cubes algorithm. module Graphics.Implicit.Export.SymbolicObj3 (symbolicGetMesh) where -import Prelude(map, zip, length, filter, (>), ($), null, concat, (++), concatMap)+import Prelude(map, zip, length, filter, (>), ($), null, (++), concatMap) import Graphics.Implicit.Definitions (ℝ, ℝ3, SymbolicObj3(UnionR3)) import Graphics.Implicit.Export.Render (getMesh)@@ -21,6 +21,8 @@ import Graphics.Implicit.MathUtil(box3sWithin) import Graphics.Implicit.Export.Symbolic.Rebound3 (rebound3) +import Control.Arrow(first, second)+ symbolicGetMesh :: ℝ -> SymbolicObj3 -> [(ℝ3, ℝ3, ℝ3)] {--@@ -203,8 +205,8 @@ sepFree :: forall a. [((ℝ3, ℝ3), a)] -> ([a], [a]) sepFree ((box,obj):others) = if length (filter (box3sWithin r box) boxes) > 1- then (\(a,b) -> (obj:a,b)) $ sepFree others- else (\(a,b) -> (a,obj:b)) $ sepFree others+ then first ((:) obj) $ sepFree others+ else second ((:) obj) $ sepFree others sepFree [] = ([],[]) (dependants, independents) = sepFree boxedObjs@@ -214,7 +216,7 @@ else if null dependants then concatMap (symbolicGetMesh res) independents else concatMap (symbolicGetMesh res) independents- ++ concat [symbolicGetMesh res (UnionR3 r dependants)]+ ++ symbolicGetMesh res (UnionR3 r dependants) -- If all that fails, coerce and apply marching cubes :( -- (rebound is for being safe about the bounding box --
Graphics/Implicit/Export/TextBuilderUtils.hs view
@@ -5,8 +5,7 @@ -- This module exists to re-export a coherent set of functions to define -- Data.Text.Lazy builders with. -module Graphics.Implicit.Export.TextBuilderUtils - (+module Graphics.Implicit.Export.TextBuilderUtils ( -- Values from Data.Text.Lazy Text, pack,@@ -25,8 +24,9 @@ mempty ) where -import Prelude (Int, Maybe(Nothing, Just), ($))+import Prelude (Maybe(Nothing, Just), ($)) +import Graphics.Implicit.Definitions(Fastℕ) import Data.Text.Lazy (Text, pack) -- We manually redefine this operator to avoid a dependency on base >= 4.5 -- This will become unnecessary later.@@ -50,7 +50,7 @@ buildTruncFloat = formatRealFloat Fixed $ Just 4 -buildInt :: Int -> Builder+buildInt :: Fastℕ -> Builder buildInt = decimal -- This is directly copied from base 4.5.1.0
Graphics/Implicit/Export/TriangleMeshFormats.hs view
@@ -8,16 +8,20 @@ -- Make string litearls more polymorphic, so we can use them with Builder. {-# LANGUAGE OverloadedStrings #-} -module Graphics.Implicit.Export.TriangleMeshFormats where+-- This module exposes three functions, which convert a triangle mesh to an output file.+module Graphics.Implicit.Export.TriangleMeshFormats (stl, binaryStl, jsTHREE) where -import Prelude (Real, Float, Int, ($), (+), map, (.), mconcat, realToFrac, toEnum, length, zip, return)+import Prelude (Real, Float, ($), (+), map, (.), realToFrac, toEnum, length, zip, return) -import Graphics.Implicit.Definitions (Triangle, TriangleMesh, ℝ3)+import Graphics.Implicit.Definitions (Triangle, TriangleMesh, Fastℕ, ℝ3) import Graphics.Implicit.Export.TextBuilderUtils (Text, Builder, toLazyText, (<>), bf, buildInt) import Blaze.ByteString.Builder (Write, writeStorable, toLazyByteString, fromByteString, fromWord32le, fromWord16le, fromWrite) import qualified Data.ByteString.Builder.Internal as BI (Builder) +-- note: moved to prelude in newer version+import Data.Monoid(mconcat)+ import Data.ByteString (replicate) import Data.ByteString.Lazy (ByteString) import Data.Storable.Endian (LittleEndian(LE))@@ -29,7 +33,7 @@ normal (a,b,c) = normalized $ (b + negateV a) `cross3` (c + negateV a) -stl :: [Triangle] -> Text+stl :: TriangleMesh -> Text stl triangles = toLazyText $ stlHeader <> mconcat (map triangle triangles) <> stlFooter where stlHeader :: Builder@@ -59,7 +63,7 @@ float32LE :: Float -> Write float32LE = writeStorable . LE -binaryStl :: [Triangle] -> ByteString+binaryStl :: TriangleMesh -> ByteString binaryStl triangles = toLazyByteString $ header <> lengthField <> mconcat (map triangle triangles) where header = fromByteString $ replicate 80 0 lengthField = fromWord32le $ toEnum $ length triangles@@ -92,7 +96,7 @@ v :: ℝ3 -> Builder v (x,y,z) = "v(" <> bf x <> "," <> bf y <> "," <> bf z <> ");\n" -- A face line- f :: Int -> Int -> Int -> Builder+ f :: Fastℕ -> Fastℕ -> Fastℕ -> Builder f posa posb posc = "f(" <> buildInt posa <> "," <> buildInt posb <> "," <> buildInt posc <> ");" verts = do@@ -105,5 +109,5 @@ facecode = mconcat $ do (n,_) <- zip [0, 3 ..] triangles let- (posa, posb, posc) = (n, n+1, n+2) :: (Int, Int, Int)+ (posa, posb, posc) = (n, n+1, n+2) :: (Fastℕ, Fastℕ, Fastℕ) return $ f posa posb posc
Graphics/Implicit/Export/Util.hs view
@@ -3,7 +3,7 @@ -- Released under the GNU AGPLV3+, see LICENSE -- FIXME: why are these needed?-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} -- Functions to make meshes/polylines finer.
Graphics/Implicit/ExtOpenScad.hs view
@@ -9,7 +9,7 @@ module Graphics.Implicit.ExtOpenScad (runOpenscad) where -import Prelude(Char, Either(Left, Right), IO, ($), fmap)+import Prelude(String, Either(Left, Right), IO, ($), fmap) import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3) import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup, OVal)@@ -24,14 +24,14 @@ import qualified System.Directory as Dir (getCurrentDirectory) -- Small wrapper to handle parse errors, etc.-runOpenscad :: [Char] -> Either Parsec.ParseError (IO (VarLookup, [SymbolicObj2], [SymbolicObj3]))-runOpenscad s =+runOpenscad :: String -> Either Parsec.ParseError (IO (VarLookup, [SymbolicObj2], [SymbolicObj3]))+runOpenscad source = let initial = defaultObjects rearrange :: forall t t1 t2 t3 t4. (t, (t4, [OVal], t1, t2, t3)) -> (t4, [SymbolicObj2], [SymbolicObj3]) rearrange (_, (varlookup, ovals, _ , _ , _)) = (varlookup, obj2s, obj3s) where (obj2s, obj3s, _ ) = divideObjs ovals- in case parseProgram "" s of+ in case parseProgram source of Left e -> Left e Right sts -> Right $ fmap rearrange
Graphics/Implicit/ExtOpenScad/Default.hs view
@@ -7,16 +7,17 @@ -- We'd like to parse openscad code, with some improvements, for backwards compatability. -module Graphics.Implicit.ExtOpenScad.Default where +module Graphics.Implicit.ExtOpenScad.Default (defaultObjects) where -import Prelude (Char, String, Bool(True, False), Maybe(Just, Nothing), Int, ($), (++), map, pi, sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, abs, signum, fromInteger, (.), floor, ceiling, round, exp, log, sqrt, max, min, atan2, (**), flip, (<), (>), (<=), (>=), (==), (/=), (&&), (||), not, show, foldl, (*), (/), mod, (+), zipWith, (-), (!!), length, otherwise, fromIntegral)+import Prelude (String, Bool(True, False), Maybe(Just, Nothing), ($), (++), map, pi, sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, abs, signum, fromInteger, (.), floor, ceiling, round, exp, log, sqrt, max, min, atan2, (**), flip, (<), (>), (<=), (>=), (==), (/=), (&&), (||), not, show, foldl, (*), (/), mod, (+), zipWith, (-), (!!), length, otherwise, fromIntegral) -import Graphics.Implicit.Definitions (ℝ)+import Graphics.Implicit.Definitions (ℝ, Fastℕ) import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup, OVal(OList, ONum, OString, OUndefined, OError, OModule, OFunc)) import Graphics.Implicit.ExtOpenScad.Util.OVal (toOObj, oTypeStr) import Graphics.Implicit.ExtOpenScad.Primitives (primitives) import Data.Map (fromList)+import Control.Arrow (second) defaultObjects :: VarLookup -- = Map String OVal defaultObjects = fromList $@@ -30,11 +31,11 @@ -- Missing standard ones: -- rand, lookup, -defaultConstants :: [([Char], OVal)]+defaultConstants :: [(String, OVal)] defaultConstants = map (\(a,b) -> (a, toOObj (b::ℝ) )) [("pi", pi)] -defaultFunctions :: [([Char], OVal)]+defaultFunctions :: [(String, OVal)] defaultFunctions = map (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ))) [ ("sin", sin),@@ -58,7 +59,7 @@ ("sqrt", sqrt) ] -defaultFunctions2 :: [([Char], OVal)]+defaultFunctions2 :: [(String, OVal)] defaultFunctions2 = map (\(a,b) -> (a, toOObj (b :: ℝ -> ℝ -> ℝ) )) [ ("max", max),@@ -67,25 +68,22 @@ ("pow", (**)) ] -defaultFunctionsSpecial :: [([Char], OVal)]+defaultFunctionsSpecial :: [(String, OVal)] defaultFunctionsSpecial = [- ("map", toOObj $ flip $+ ("map", toOObj $ flip (map :: (OVal -> OVal) -> [OVal] -> [OVal] ) ) ] - defaultModules :: [(String, OVal)] defaultModules =- map (\(a,b) -> (a, OModule b)) primitives--+ map (second OModule) primitives -- more complicated ones: -defaultPolymorphicFunctions :: [([Char], OVal)]+defaultPolymorphicFunctions :: [(String, OVal)] defaultPolymorphicFunctions = [ ("+", sumtotal),@@ -138,7 +136,7 @@ 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 $ fromInteger $ mod (floor a) (floor b)+ omod (ONum a) (ONum b) = ONum . fromInteger $ mod (floor a) (floor b) omod a b = errorAsAppropriate "modulo" a b append (OList a) (OList b) = OList $ a++b@@ -175,13 +173,13 @@ index (OList l) (ONum ind) = let- n :: Int+ n :: Fastℕ 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 :: Int+ n :: Fastℕ 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@@ -190,27 +188,27 @@ 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 ) =+ osplice (OList list) OUndefined (ONum b ) = OList $ splice list 0 (floor b)- osplice (OString str) (OUndefined) (ONum b ) =+ osplice (OString str) OUndefined (ONum b ) = OString $ splice str 0 (floor b)- osplice (OList list) (ONum a) ( OUndefined) =+ osplice (OList list) (ONum a) OUndefined = OList $ splice list (floor a) (length list + 1)- osplice (OString str) (ONum a) ( OUndefined) =+ osplice (OString str) (ONum a) OUndefined = OString $ splice str (floor a) (length str + 1)- osplice (OList list) (OUndefined) (OUndefined) =+ osplice (OList list) OUndefined OUndefined = OList $ splice list 0 (length list + 1)- osplice (OString str) (OUndefined) (OUndefined) =+ osplice (OString str) OUndefined OUndefined = OString $ splice str 0 (length str + 1) osplice _ _ _ = OUndefined - splice :: [a] -> Int -> Int -> [a]+ splice :: [a] -> Fastℕ -> Fastℕ -> [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) )+ | b > 0 = x: splice xs a (b-1) | otherwise = [] where n = length l @@ -237,7 +235,7 @@ ternary True a _ = a ternary False _ b = b - olength (OString s) = ONum $ fromIntegral $ length s- olength (OList s) = ONum $ fromIntegral $ length s+ olength (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
@@ -14,12 +14,13 @@ TestInvariant(EulerCharacteristic), collector) where -import Prelude(Eq, Show, String, Maybe, Bool(True, False), Int, IO, (==), show, map, ($), (++), undefined, all, id, zipWith, foldl1)+import Prelude(Eq, Show, String, Maybe, Bool(True, False), IO, (==), show, map, ($), (++), undefined, and, zipWith, foldl1) -import Graphics.Implicit.Definitions (ℝ, SymbolicObj2, SymbolicObj3)+-- Resolution of the world, Integer operator, and symbolic languages for 2D and 3D objects.+import Graphics.Implicit.Definitions (ℝ, Fastℕ, ℕ, SymbolicObj2, SymbolicObj3) import Control.Applicative (Applicative, Alternative((<|>), empty), pure, (<*>))-import Control.Monad (Functor, Monad, fmap, (>>=), mzero, mplus, MonadPlus, liftM, ap)+import Control.Monad (Functor, Monad, fmap, (>>=), mzero, mplus, MonadPlus, liftM, ap, return, (>=>)) import Data.Map (Map) -----------------------------------------------------------------@@ -45,14 +46,14 @@ fmap = liftM instance Applicative ArgParser where- pure a = APTerminator a+ pure = APTerminator (<*>) = ap instance Monad ArgParser where -- We need to describe how (>>=) works. -- Let's get the hard ones out of the way first. -- ArgParser actually- (AP str fallback d f) >>= g = AP str fallback d (\a -> (f a) >>= g)+ (AP str fallback d f) >>= g = AP str fallback d (f >=> g) (APFailIf b errmsg child) >>= g = APFailIf b errmsg (child >>= g) -- These next to is easy, they just pass the work along to their child (APExample str child) >>= g = APExample str (child >>= g)@@ -60,12 +61,13 @@ -- And an ArgParserTerminator happily gives away the value it contains (APTerminator a) >>= g = g a (APBranch bs) >>= g = APBranch $ map (>>= g) bs+ return = pure 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 (APBranch bs) = APBranch ( a : bs ) mplus a b = APBranch [ a , b ] instance Alternative ArgParser where@@ -87,7 +89,8 @@ | Expr :$ [Expr] deriving (Show, Eq) -data StatementI = StatementI Int (Statement StatementI)+-- a statement, along with the line number it is found on.+data StatementI = StatementI Fastℕ (Statement StatementI) deriving (Show, Eq) data Statement st = Include String Bool@@ -117,7 +120,7 @@ instance Eq OVal where (OBool a) == (OBool b) = a == b (ONum a) == (ONum b) = a == b- (OList a) == (OList b) = all id $ zipWith (==) a b+ (OList a) == (OList b) = and $ zipWith (==) a b (OString a) == (OString b) = a == b _ == _ = False @@ -140,6 +143,6 @@ collector _ [x] = x collector s l = Var s :$ [ListE l] -data TestInvariant = EulerCharacteristic Int+newtype TestInvariant = EulerCharacteristic ℕ deriving (Show)
Graphics/Implicit/ExtOpenScad/Eval/Expr.hs view
@@ -4,7 +4,7 @@ module Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, matchPat) where -import Prelude (String, Maybe(Just, Nothing), IO, concat, ($), map, return, zip, (==), (!!), const, (++), foldr, concatMap)+import Prelude (String, Maybe(Just, Nothing), IO, concat, ($), map, return, zip, (!!), const, (++), foldr, concatMap) import Graphics.Implicit.ExtOpenScad.Definitions ( Pattern(Name, ListP, Wild),@@ -15,11 +15,12 @@ import Graphics.Implicit.ExtOpenScad.Util.OVal (oTypeStr, getErrors) import Graphics.Implicit.ExtOpenScad.Util.StateC (StateC, getVarLookup) -import Data.List (findIndex)+import Data.List (elemIndex) import Data.Map (fromList, lookup) import Control.Monad (zipWithM, mapM, forM) import Control.Monad.State (StateT, get, modify, liftIO, runStateT) +import Control.Arrow (second) patVars :: Pattern -> [String] patVars (Name name) = [name]@@ -40,22 +41,19 @@ vals <- patMatch pat val return $ fromList $ zip vars vals - evalExpr :: Expr -> StateC OVal evalExpr expr = do varlookup <- getVarLookup (valf, _) <- liftIO $ runStateT (evalExpr' expr) (varlookup, []) return $ valf [] -- evalExpr' :: Expr -> StateT (VarLookup, [String]) IO ([OVal] -> OVal) evalExpr' (Var name ) = do (varlookup, namestack) <- get return $- case (lookup name varlookup, findIndex (==name) namestack) of- (_, Just pos) -> \s -> s !! pos+ case (lookup name varlookup, elemIndex name namestack) of+ (_, Just pos) -> (!! pos) (Just val, _) -> const val _ -> const $ OError ["Variable " ++ name ++ " not in scope" ] @@ -80,7 +78,7 @@ evalExpr' (LamE pats fexpr) = do fparts <- forM pats $ \pat -> do- modify (\(vl, names) -> (vl, patVars pat ++ names))+ modify (second (patVars pat ++)) return $ \f xss -> OFunc $ \val -> case patMatch pat val of Just xs -> f (xs ++ xss) Nothing -> OError ["Pattern match failed"]
Graphics/Implicit/ExtOpenScad/Eval/Statement.hs view
@@ -2,9 +2,9 @@ -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE -{-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} -module Graphics.Implicit.ExtOpenScad.Eval.Statement where+module Graphics.Implicit.ExtOpenScad.Eval.Statement (runStatementI) where import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left, Right), FilePath, IO, (.), ($), show, putStrLn, concatMap, return, (++), fmap, reverse, fst, readFile) @@ -23,8 +23,10 @@ import Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, matchPat) import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram) +import Data.Maybe(fromMaybe)+ import qualified Data.Map as Map-import qualified Control.Monad as Monad+import Control.Monad (forM_, forM, mapM_) import Control.Monad.State (get, liftIO, mapM, runStateT, (>>)) import qualified System.FilePath as FilePath @@ -52,7 +54,7 @@ val <- evalExpr expr case (getErrors val, val) of (Just err, _) -> errorC lineN err- (_, OList vals) -> Monad.forM_ vals $ \v ->+ (_, OList vals) -> forM_ vals $ \v -> case matchPat pat v of Just match -> do modifyVarLookup $ Map.union match@@ -69,13 +71,13 @@ _ -> return () runStatementI (StatementI lineN (NewModule name argTemplate suite)) = do- argTemplate' <- Monad.forM argTemplate $ \(name', defexpr) -> do+ argTemplate' <- forM argTemplate $ \(name', defexpr) -> do defval <- mapMaybeM evalExpr defexpr return (name', defval) (varlookup, _, path, _, _) <- get -- FIXME: \_? really?- runStatementI $ StatementI lineN $ (Name name :=) $ LitE $ OModule $ \_ -> do- newNameVals <- Monad.forM argTemplate' $ \(name', maybeDef) -> do+ runStatementI . StatementI lineN $ (Name name :=) $ LitE $ OModule $ \_ -> do+ newNameVals <- forM argTemplate' $ \(name', maybeDef) -> do val <- case maybeDef of Just def -> argument name' `defaultTo` def Nothing -> argument name'@@ -105,19 +107,17 @@ maybeMod <- lookupVar name (varlookup, _, path, _, _) <- get childVals <- fmap reverse . liftIO $ runSuiteCapture varlookup path suite- argsVal <- Monad.forM argsExpr $ \(posName, expr) -> do+ argsVal <- 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 []+ ioNewVals = fromMaybe (return []) (fst $ argMap argsVal argparser) Just foo -> do case getErrors foo of Just err -> errorC lineN err- Nothing -> errorC lineN $ "Object called not module!"+ Nothing -> errorC lineN "Object called not module!" return [] Nothing -> do errorC lineN $ "Module " ++ name ++ " not in scope."@@ -127,7 +127,7 @@ runStatementI (StatementI _ (Include name injectVals)) = do name' <- getRelPath name content <- liftIO $ readFile name'- case parseProgram name content of+ case parseProgram content of Left e -> liftIO $ putStrLn $ "Error parsing " ++ name ++ ":" ++ show e Right sts -> withPathShiftedBy (FilePath.takeDirectory name) $ do vals <- getVals@@ -136,12 +136,10 @@ vals' <- getVals if injectVals then putVals (vals' ++ vals) else putVals vals --runStatementI (StatementI _ DoNothing) = do- liftIO $ putStrLn $ "Do Nothing?"+runStatementI (StatementI _ DoNothing) = liftIO $ putStrLn "Do Nothing?" runSuite :: [StatementI] -> StateC ()-runSuite stmts = Monad.mapM_ runStatementI stmts+runSuite = mapM_ runStatementI runSuiteCapture :: VarLookup -> FilePath -> [StatementI] -> IO [OVal] runSuiteCapture varlookup path suite = do
Graphics/Implicit/ExtOpenScad/Parser/Expr.hs view
@@ -2,9 +2,10 @@ -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE -module Graphics.Implicit.ExtOpenScad.Parser.Expr where+-- a parser for a numeric expression.+module Graphics.Implicit.ExtOpenScad.Parser.Expr(expr0) where -import Prelude (Char, Maybe(Nothing, Just), fmap, ($), (>>), return, Bool(True, False), read, (++), id, foldl, map, foldl1, unzip, tail, zipWith3)+import Prelude (Char, Maybe(Nothing, Just), fmap, ($), (.), (>>), return, Bool(True, False), read, (++), (*), (**), (/), id, foldl, map, foldl1, unzip, tail, zipWith3) -- the datatype representing the graininess of our world. import Graphics.Implicit.Definitions (ℝ)@@ -13,6 +14,7 @@ import Text.ParserCombinators.Parsec (GenParser, string, many1, digit, char, many, noneOf, sepBy, sepBy1, optionMaybe, try) import Graphics.Implicit.ExtOpenScad.Definitions (Expr(Var, LitE, ListE, (:$)), OVal(ONum, OString, OBool, OUndefined), collector) + import Graphics.Implicit.ExtOpenScad.Parser.Util (variableSymb, (?:), (*<|>), genSpace, padString) variable :: GenParser Char st Expr@@ -23,27 +25,66 @@ "boolean" ?: do b <- (string "true" >> return True ) *<|> (string "false" >> return False)- return $ LitE $ OBool b+ return . LitE $ OBool b+ -- FIXME: this is a hack, implement something like exprN to replace this? *<|> "number" ?: (- do+ do a <- many1 digit+ _ <- char 'e'+ b <- many1 digit+ return . LitE $ ONum (((read a) * (10 ** (read b))) :: ℝ)+ *<|> do+ a <- many1 digit _ <- char '.' b <- many digit- return $ LitE $ ONum (read (a ++ "." ++ b) :: ℝ)+ _ <- char 'e'+ c <- many1 digit+ return . LitE $ ONum ((read (a ++ "." ++ b) * (10 ** (read c))) :: ℝ) *<|> do a <- many1 digit- return $ LitE $ ONum (read a :: ℝ)+ _ <- char '.'+ b <- many digit+ _ <- char 'e'+ _ <- char '+'+ c <- many1 digit+ return . LitE $ ONum ((read (a ++ "." ++ b) * (10 ** (read c))) :: ℝ)+ *<|> do+ a <- many1 digit+ _ <- char '.'+ b <- many digit+ _ <- char 'e'+ _ <- char '-'+ c <- many1 digit+ return . LitE $ ONum ((read (a ++ "." ++ b) / (10 ** (read c))) :: ℝ)+ *<|> do+ a <- many1 digit+ _ <- char 'e'+ _ <- char '-'+ b <- many1 digit+ return . LitE $ ONum (((read a) / (10 ** (read b))) :: ℝ)+ *<|> do+ a <- many1 digit+ _ <- char '.'+ b <- many digit+ return . LitE $ ONum (read (a ++ "." ++ b) :: ℝ)+ *<|> do+ a <- many1 digit+ return . LitE $ ONum (read a :: ℝ) )- *<|> "string" ?: do+ *<|> "string" ?: do _ <- string "\"" strlit <- many $ (string "\\\"" >> return '\"') *<|> (string "\\n" >> return '\n')- *<|> ( noneOf "\"\n")+ *<|> (string "\\r" >> return '\r')+ *<|> (string "\\t" >> return '\t')+ *<|> (string "\\\\" >> return '\\')+ -- FIXME: no \u unicode support?+ *<|> noneOf "\"\n" _ <- string "\""- return $ LitE $ OString strlit+ return . LitE $ OString strlit -- We represent the priority or 'fixity' of different types of expressions--- by the Int argument+-- by the ExprIdx argument, with A0 as the highest. expr0 :: GenParser Char st Expr expr0 = exprN A0@@ -85,7 +126,7 @@ exprN A11 = do- obj <- exprN $ A12+ obj <- exprN A12 _ <- genSpace mods <- many1 ( "function application" ?: do@@ -111,67 +152,73 @@ (Just s, Just e ) -> \l -> Var "splice" :$ [l, s, e] ) return $ foldl (\a b -> b a) obj mods- *<|> (exprN $ A12 )+ *<|> exprN A12 +-- match a leading (+) or (-) operator. exprN A10 = "negation" ?: do _ <- padString "-"- expr <- exprN $ A11+ expr <- exprN A11 return $ Var "negate" :$ [expr] *<|> do _ <- padString "+"- expr <- exprN $ A11- return expr- *<|> exprN (A11)+ exprN A11+ *<|> exprN A11 +-- match power-of (^) operator. exprN A9 = "exponentiation" ?: do- a <- exprN $ A10+ a <- exprN A10 _ <- padString "^" b <- exprN A9 return $ Var "^" :$ [a,b]- *<|> exprN (A10)+ *<|> exprN A10 +-- match sequences of multiplication and division. exprN A8 = "multiplication/division" ?: do -- outer list is multiplication, inner division. -- eg. "1*2*3/4/5*6*7/8" -- [[1],[2],[3,4,5],[6],[7,8]] exprs <- sepBy1- (sepBy1 (exprN $ A9) (try $ padString "/" ))+ (sepBy1 (exprN A9) (try $ padString "/" )) (try $ padString "*" ) let div' a b = Var "/" :$ [a, b]- return $ collector "*" $ map (foldl1 div') exprs- *<|> exprN (A9)+ return . collector "*" $ map (foldl1 div') exprs+ *<|> exprN A9 +-- match remainder (%) operator. exprN A7 = "modulo" ?: do- exprs <- sepBy1 (exprN $ A8) (try $ padString "%")+ exprs <- sepBy1 (exprN A8) (try $ padString "%") let mod' a b = Var "%" :$ [a, b] return $ foldl1 mod' exprs- *<|> exprN (A8)+ *<|> exprN A8 +-- match string addition (++) operator. exprN A6 = "append" ?: do- exprs <- sepBy1 (exprN $ A7) (try $ padString "++")+ exprs <- sepBy1 (exprN A7) (try $ padString "++") return $ collector "++" exprs- *<|> exprN (A7)+ *<|> exprN A7 +-- match sequences of addition and subtraction. exprN A5 = "addition/subtraction" ?: do -- Similar to multiply & divide -- eg. "1+2+3-4-5+6-7" -- [[1],[2],[3,4,5],[6,7]] exprs <- sepBy1- (sepBy1 (exprN $ A6) (try $ padString "-" ))+ (sepBy1 (exprN A6) (try $ padString "-" )) (try $ padString "+" ) let sub a b = Var "-" :$ [a, b]- return $ collector "+" $ map (foldl1 sub) exprs- *<|> exprN (A6)+ return . collector "+" $ map (foldl1 sub) exprs+ *<|> exprN A6 +-- match comparison operators. exprN A4 = do- firstExpr <- exprN $ A5+ firstExpr <- exprN A5 otherComparisonsExpr <- many $ do comparisonSymb <- padString "=="@@ -180,7 +227,7 @@ *<|> padString "<=" *<|> padString ">" *<|> padString "<"- expr <- exprN $ A5+ expr <- exprN A5 return (Var comparisonSymb, expr) let (comparisons, otherExprs) = unzip otherComparisonsExpr@@ -189,39 +236,43 @@ [] -> firstExpr [x] -> x :$ exprs _ -> collector "all" $ zipWith3 (\c e1 e2 -> c :$ [e1,e2]) comparisons exprs (tail exprs)- *<|> exprN (A5)+ *<|> exprN A5 +-- match the logical negation operator. exprN A3 = "logical-not" ?: do _ <- padString "!"- a <- exprN $ A4+ a <- exprN A4 return $ Var "!" :$ [a]- *<|> exprN (A4)+ *<|> exprN A4 +-- match the logical And and Or (&&,||) operators. exprN A2 = "logical and/or" ?: do- a <- exprN $ A3+ a <- exprN A3 symb <- padString "&&" *<|> padString "||" b <- exprN A2 return $ Var symb :$ [a,b]- *<|> exprN (A3)+ *<|> exprN A3 +-- match the ternary (1?2:3) operator. exprN A1 = "ternary" ?: do- a <- exprN $ A2+ a <- exprN A2 _ <- padString "?" b <- exprN A1 _ <- padString ":" c <- exprN A1 return $ Var "?" :$ [a,b,c]- *<|> exprN (A2)+ *<|> exprN A2 +-- Match and throw away any white space around an expression. exprN A0 = do _ <- genSpace- expr <- exprN $ A1+ expr <- exprN A1 _ <- genSpace return expr- *<|> exprN (A1)+ *<|> exprN A1
Graphics/Implicit/ExtOpenScad/Parser/Statement.hs view
@@ -8,7 +8,8 @@ -- FIXME: required. why? {-# LANGUAGE KindSignatures #-} -module Graphics.Implicit.ExtOpenScad.Parser.Statement where+-- The entry point for parsing an ExtOpenScad program.+module Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram) where import Prelude(Char, Either, String, Maybe(Just, Nothing), Monad, return, fmap, ($), (>>), Bool(False, True), map) @@ -20,17 +21,19 @@ import Graphics.Implicit.ExtOpenScad.Definitions (Pattern(Name), Statement(DoNothing, NewModule, Include, Echo, If, For, ModuleCall,(:=)),Expr(LamE), StatementI(StatementI)) import Graphics.Implicit.ExtOpenScad.Parser.Util (genSpace, tryMany, stringGS, (*<|>), (?:), patternMatcher, variableSymb)++-- the top level of the expression parser. import Graphics.Implicit.ExtOpenScad.Parser.Expr (expr0) -parseProgram :: SourceName -> [Char] -> Either ParseError [StatementI]-parseProgram name s = parse program name s where- program :: ParsecT [Char] u Identity [StatementI]+parseProgram :: String -> Either ParseError [StatementI]+parseProgram = parse program "" where -- "" is our program name.+ program :: ParsecT String u Identity [StatementI] program = do sts <- many1 computation eof return sts --- | A in our programming openscad-like programming language.+-- | A computable block of code in our openscad-like programming language. computation :: GenParser Char st StatementI computation = do -- suite statements: no semicolon...@@ -39,30 +42,21 @@ ifStatementI, forStatementI, throwAway,- userModuleDeclaration{-,- unimplemented "mirror",- unimplemented "multmatrix",- unimplemented "color",- unimplemented "render",- unimplemented "surface",- unimplemented "projection",- unimplemented "import_stl"-}- -- rotateExtrude+ userModuleDeclaration ] _ <- genSpace return s- *<|> do -- Non suite s. Semicolon needed...+ *<|> do -- Non suite statements. Semicolon needed... _ <- genSpace s <- tryMany [ echo,- include,+ include, -- also handles use function,- assignment--,- --use+ assignment ] _ <- stringGS " ; " return s- *<|> do -- Modules+ *<|> do -- Modules. no semicolon... _ <- genSpace s <- userModule _ <- genSpace@@ -81,9 +75,8 @@ -- -- union() sphere(3); ----- We consider it to be a list of s which+-- We consider it to be a list of computables which -- are in turn StatementI s.--- So this parses them. -} suite :: GenParser Char st [StatementI] suite = (fmap return computation <|> do@@ -95,7 +88,7 @@ return stmts ) <?> " suite" -+-- commenting out a comuptation: use % or * before the statement, and it will not be run. throwAway :: GenParser Char st StatementI throwAway = do line <- lineNumber@@ -105,7 +98,7 @@ _ <- computation return $ StatementI line DoNothing --- An included ! Basically, inject another openscad file here...+-- An include! Basically, inject another openscad file here... include :: GenParser Char st StatementI include = (do line <- lineNumber@@ -117,34 +110,34 @@ return $ StatementI line $ Include filename injectVals ) <?> "include " --- | An assignment (parser)+-- | An assignment (parser) assignment :: GenParser Char st StatementI assignment = ("assignment " ?:) $ do line <- lineNumber- pattern <- patternMatcher+ lvalue <- patternMatcher _ <- stringGS " = " valExpr <- expr0- return $ StatementI line$ pattern := valExpr+ return $ StatementI line $ lvalue := valExpr -- | A function declaration (parser) function :: GenParser Char st StatementI function = ("function " ?:) $ do line <- lineNumber- varSymb <- (string "function" >> space >> genSpace >> variableSymb)+ varSymb <- string "function" >> space >> genSpace >> variableSymb _ <- stringGS " ( " argVars <- sepBy patternMatcher (stringGS " , ") _ <- stringGS " ) = " valExpr <- expr0 return $ StatementI line $ Name varSymb := LamE argVars valExpr --- | An echo (parser)+-- | An echo (parser) echo :: GenParser Char st StatementI echo = do line <- lineNumber _ <- stringGS "echo ( "- exprs <- expr0 `sepBy` (stringGS " , ")+ exprs <- expr0 `sepBy` stringGS " , " _ <- stringGS " ) " return $ StatementI line $ Echo exprs @@ -157,7 +150,7 @@ _ <- stringGS " ) " sTrueCase <- suite _ <- genSpace- sFalseCase <- (stringGS "else " >> suite ) *<|> (return [])+ sFalseCase <- (stringGS "else " >> suite ) *<|> return [] return $ StatementI line $ If bexpr sTrueCase sFalseCase forStatementI :: GenParser Char st StatementI@@ -169,13 +162,14 @@ -- eg. for ( a = [1,2,3] ) {echo(a); echo "lol";} -- eg. for ( [a,b] = [[1,2]] ) {echo(a+b); echo "lol";} _ <- stringGS "for ( "- pattern <- patternMatcher+ lvalue <- patternMatcher _ <- stringGS " = " vexpr <- expr0 _ <- stringGS " ) " loopContent <- suite- return $ StatementI line $ For pattern vexpr loopContent+ return $ StatementI line $ For lvalue vexpr loopContent +-- parse a call to a module. userModule :: GenParser Char st StatementI userModule = do line <- lineNumber@@ -186,6 +180,7 @@ s <- suite *<|> (stringGS " ; " >> return []) return $ StatementI line $ ModuleCall name args s +-- declare a module. userModuleDeclaration :: GenParser Char st StatementI userModuleDeclaration = do line <- lineNumber@@ -197,8 +192,7 @@ s <- suite return $ StatementI line $ NewModule newModuleName args s ------------------------+-- parse the arguments passed to a module. moduleArgsUnit :: GenParser Char st [(Maybe String, Expr)] moduleArgsUnit = do _ <- stringGS " ( "@@ -208,7 +202,7 @@ symb <- variableSymb _ <- stringGS " = " expr <- expr0- return $ (Just symb, expr)+ return (Just symb, expr) *<|> do -- eg. a(x,y) = 12 symb <- variableSymb@@ -216,7 +210,7 @@ argVars <- sepBy variableSymb (try $ stringGS " , ") _ <- stringGS " ) = " expr <- expr0- return $ (Just symb, LamE (map Name argVars) expr)+ return (Just symb, LamE (map Name argVars) expr) *<|> do -- eg. 12 expr <- expr0@@ -225,6 +219,7 @@ _ <- stringGS " ) " return args +-- parse the arguments in the module declaration. moduleArgsUnitDecl :: GenParser Char st [(String, Maybe Expr)] moduleArgsUnitDecl = do _ <- stringGS " ( "@@ -241,8 +236,6 @@ _ <- sepBy variableSymb (try $ stringGS " , ") _ <- stringGS " ) = " expr <- expr0--- FIXME: this line looks right, but.. what does this change?--- return $ (Just symb, LamE (map Name argVars) expr) return (symb, Just expr) *<|> do symb <- variableSymb@@ -251,12 +244,14 @@ _ <- stringGS " ) " return argTemplate +-- find the line number. used when generating errors. lineNumber :: forall s u (m :: * -> *). Monad m => ParsecT s u m Line lineNumber = fmap sourceLine getPosition --FIXME: use the below function to improve error reporting. {-+-- find the column number. SHOULD be used when generating errors. columnNumber :: forall s u (m :: * -> *). Monad m => ParsecT s u m Column columnNumber = fmap sourceColumn getPosition
Graphics/Implicit/ExtOpenScad/Parser/Util.hs view
@@ -13,26 +13,29 @@ import Prelude (String, Char, ($), (++), foldl1, map, (>>), (.), return) import Text.ParserCombinators.Parsec (GenParser, many, oneOf, noneOf, (<|>), try, string, manyTill, anyChar, (<?>), char, many1, sepBy)+ import Text.Parsec.Prim (ParsecT, Stream)+ import Data.Functor.Identity (Identity)+ import Graphics.Implicit.ExtOpenScad.Definitions (Pattern(Wild, Name, ListP)) -- white space, including tabs, newlines and comments-genSpace :: ParsecT [Char] u Identity [Char]+genSpace :: ParsecT String u Identity String genSpace = many $ oneOf " \t\n\r"- <|> (try $ do+ <|> try ( do _ <- string "//" _ <- many ( noneOf "\n")- _ <- string "\n" return ' '- ) <|> (try $ do+ ) <|> try ( do _ <- string "/*" _ <- manyTill anyChar (try $ string "*/") return ' ' ) -pad :: forall b u. ParsecT [Char] u Identity b -> ParsecT [Char] u Identity b+-- a padded ... parser?+pad :: ParsecT String u Identity b -> ParsecT String u Identity b pad parser = do _ <- genSpace a <- parser@@ -47,7 +50,7 @@ (?:) :: forall s u (m :: * -> *) a. String -> ParsecT s u m a -> ParsecT s u m a l ?: p = p <?> l -stringGS :: [Char] -> ParsecT [Char] u Identity [Char]+stringGS :: String -> ParsecT String u Identity String stringGS (' ':xs) = do x' <- genSpace xs' <- stringGS xs@@ -58,7 +61,8 @@ return (x' : xs') stringGS "" = return "" -padString :: String -> ParsecT [Char] u Identity String+-- a padded string+padString :: String -> ParsecT String u Identity String padString s = do _ <- genSpace s' <- string s@@ -66,9 +70,9 @@ return s' tryMany :: forall u a tok. [GenParser tok u a] -> ParsecT [tok] u Identity a-tryMany = (foldl1 (<|>)) . (map try)+tryMany = foldl1 (<|>) . map try -variableSymb :: forall s u (m :: * -> *). Stream s m Char => ParsecT s u m [Char]+variableSymb :: forall s u (m :: * -> *). Stream s m Char => ParsecT s u m String variableSymb = many1 (noneOf " ,|[]{}()+-*&^%#@!~`'\"\\/;:.,<>?=") <?> "variable" patternMatcher :: GenParser Char st Pattern@@ -88,7 +92,7 @@ ) <|> ( do _ <- char '[' _ <- genSpace- components <- patternMatcher `sepBy` (try $ genSpace >> char ',' >> genSpace)+ components <- patternMatcher `sepBy` try (genSpace >> char ',' >> genSpace) _ <- genSpace _ <- char ']' return $ ListP components
Graphics/Implicit/ExtOpenScad/Primitives.hs view
@@ -12,7 +12,7 @@ -- Export one set containing all of the primitive object's patern matches. module Graphics.Implicit.ExtOpenScad.Primitives (primitives) where -import Prelude(String, IO, Char, Either(Left, Right), Bool(False), Maybe(Just, Nothing), Fractional, ($), return, either, id, (-), (==), (&&), (<), fromIntegral, (*), cos, sin, pi, (/), (>), const, uncurry, realToFrac, fmap, fromInteger, round, (/=), (||), not, null, map, (++), putStrLn)+import Prelude(String, IO, Either(Left, Right), Bool(False), Maybe(Just, Nothing), Fractional, ($), return, either, id, (-), (==), (&&), (<), fromIntegral, (*), cos, sin, pi, (/), (>), const, uncurry, realToFrac, fmap, fromInteger, round, (/=), (||), not, null, map, (++), putStrLn) import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, ℕ, SymbolicObj2, SymbolicObj3) @@ -37,7 +37,7 @@ -- sphere is a module without a suite. -- this means that the parser will look for this like -- sphere(args...);-sphere :: ([Char], [OVal] -> ArgParser (IO [OVal]))+sphere :: (String, [OVal] -> ArgParser (IO [OVal])) sphere = moduleWithoutSuite "sphere" $ do example "sphere(3);" example "sphere(r=5);"@@ -52,7 +52,7 @@ -- (Graphics.Implicit.Primitives) addObj3 $ Prim.sphere r -cube :: ([Char], [OVal] -> ArgParser (IO [OVal]))+cube :: (String, [OVal] -> ArgParser (IO [OVal])) cube = moduleWithoutSuite "cube" $ do -- examples@@ -98,7 +98,7 @@ addObj3 $ Prim.rect3R r (x1, y1, z1) (x2, y2, z2) -square :: ([Char], [OVal] -> ArgParser (IO [OVal]))+square :: (String, [OVal] -> ArgParser (IO [OVal])) square = moduleWithoutSuite "square" $ do -- examples@@ -142,7 +142,7 @@ addObj2 $ Prim.rectR r (x1, y1) (x2, y2) -cylinder :: ([Char], [OVal] -> ArgParser (IO [OVal]))+cylinder :: (String, [OVal] -> ArgParser (IO [OVal])) cylinder = moduleWithoutSuite "cylinder" $ do example "cylinder(r=10, h=30, center=true);"@@ -197,7 +197,7 @@ in shift obj3 else shift $ Prim.cylinder2 r1 r2 dh -circle :: ([Char], [OVal] -> ArgParser (IO [OVal]))+circle :: (String, [OVal] -> ArgParser (IO [OVal])) circle = moduleWithoutSuite "circle" $ do example "circle(r=10); // circle"@@ -221,14 +221,14 @@ sides = fromIntegral fn in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]] -polygon :: ([Char], [OVal] -> ArgParser (IO [OVal]))+polygon :: (String, [OVal] -> ArgParser (IO [OVal])) polygon = moduleWithoutSuite "polygon" $ do example "polygon ([(0,0), (0,10), (10,0)]);" - points :: [ℝ2] <- argument "points"+ points :: [ℝ2] <- argument "points" `doc` "vertices of the polygon"- paths :: [ℕ ] <- argument "paths"+ paths :: [ℕ] <- argument "paths" `doc` "order to go through vertices; ignored for now" `defaultTo` [] r :: ℝ <- argument "r"@@ -239,7 +239,7 @@ _ -> return $ return [] -union :: ([Char], [OVal] -> ArgParser (IO [OVal]))+union :: (String, [OVal] -> ArgParser (IO [OVal])) union = moduleWithSuite "union" $ \children -> do r :: ℝ <- argument "r" `defaultTo` 0.0@@ -248,7 +248,7 @@ then objReduce (Prim.unionR r) (Prim.unionR r) children else objReduce Prim.union Prim.union children -intersect :: ([Char], [OVal] -> ArgParser (IO [OVal]))+intersect :: (String, [OVal] -> ArgParser (IO [OVal])) intersect = moduleWithSuite "intersection" $ \children -> do r :: ℝ <- argument "r" `defaultTo` 0.0@@ -257,7 +257,7 @@ then objReduce (Prim.intersectR r) (Prim.intersectR r) children else objReduce Prim.intersect Prim.intersect children -difference :: ([Char], [OVal] -> ArgParser (IO [OVal]))+difference :: (String, [OVal] -> ArgParser (IO [OVal])) difference = moduleWithSuite "difference" $ \children -> do r :: ℝ <- argument "r" `defaultTo` 0.0@@ -266,7 +266,7 @@ then objReduce (Prim.differenceR r) (Prim.differenceR r) children else objReduce Prim.difference Prim.difference children -translate :: ([Char], [OVal] -> ArgParser (IO [OVal]))+translate :: (String, [OVal] -> ArgParser (IO [OVal])) translate = moduleWithSuite "translate" $ \children -> do example "translate ([2,3]) circle (4);"@@ -297,11 +297,12 @@ deg2rad x = x / 180.0 * pi -- This is mostly insane-rotate :: ([Char], [OVal] -> ArgParser (IO [OVal]))+rotate :: (String, [OVal] -> ArgParser (IO [OVal])) 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)+ 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@@ -317,14 +318,14 @@ objMap id (Prim.rotate3 (deg2rad yz, deg2rad zx, 0)) children ) <||> const [] -scale :: ([Char], [OVal] -> ArgParser (IO [OVal]))+scale :: (String, [OVal] -> ArgParser (IO [OVal])) scale = moduleWithSuite "scale" $ \children -> do example "scale(2) square(5);" example "scale([2,3]) square(5);" example "scale([2,3,4]) cube(5);" - v :: Either ℝ (Either ℝ2 ℝ3) <- argument "v"+ v <- argument "v" `doc` "vector or scalar to scale by" let@@ -336,11 +337,11 @@ Right (Left (x,y)) -> scaleObjs (x,y) (x,y,1) Right (Right (x,y,z)) -> scaleObjs (x,y) (x,y,z) -extrude :: ([Char], [OVal] -> ArgParser (IO [OVal]))+extrude :: (String, [OVal] -> ArgParser (IO [OVal])) extrude = moduleWithSuite "linear_extrude" $ \children -> do example "linear_extrude(10) square(5);" - height :: Either ℝ (ℝ -> ℝ -> ℝ) <- argument "height" `defaultTo` (Left 1)+ height :: Either ℝ (ℝ -> ℝ -> ℝ) <- argument "height" `defaultTo` Left 1 `doc` "height to extrude to..." center :: Bool <- argument "center" `defaultTo` False `doc` "center? (the z component)"@@ -384,12 +385,12 @@ shiftAsNeeded $ Prim.extrudeRM r twist' scale' translate' obj height' ) children -rotateExtrude :: ([Char], [OVal] -> ArgParser (IO [OVal]))+rotateExtrude :: (String, [OVal] -> ArgParser (IO [OVal])) rotateExtrude = moduleWithSuite "rotate_extrude" $ \children -> do example "rotate_extrude() translate(20) circle(10);" - totalRot :: ℝ <- argument "a" `defaultTo` 360- `doc` "angle to sweep"+ totalRot :: ℝ <- argument "a" `defaultTo` 360+ `doc` "angle to sweep" r :: ℝ <- argument "r" `defaultTo` 0 translateArg :: Either ℝ2 (ℝ -> ℝ2) <- argument "translate" `defaultTo` Left (0,0) rotateArg :: Either ℝ (ℝ -> ℝ ) <- argument "rotate" `defaultTo` Left 0@@ -398,8 +399,8 @@ is360m :: RealFrac a => a -> Bool is360m n = 360 * fromInteger (round $ n / 360) /= n cap = is360m totalRot- || (either ( /= (0,0)) (\f -> f 0 /= f totalRot) ) translateArg- || (either (is360m) (\f -> is360m (f 0 - f totalRot)) ) rotateArg+ || either ( /= (0,0)) (\f -> f 0 /= f totalRot) translateArg+ || either is360m (\f -> is360m (f 0 - f totalRot)) rotateArg capM = if cap then Just r else Nothing return $ return $ obj2UpMap (Prim.rotateExtrude totalRot capM translateArg rotateArg) children@@ -414,7 +415,7 @@ getAndModUpObj2s suite (\obj -> extrudeRMod r (\θ (x,y) -> (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ)) ) obj h) -} -shell :: ([Char], [OVal] -> ArgParser (IO [OVal]))+shell :: (String, [OVal] -> ArgParser (IO [OVal])) shell = moduleWithSuite "shell" $ \children-> do w :: ℝ <- argument "w" `doc` "width of the shell..."@@ -422,7 +423,7 @@ return $ return $ objMap (Prim.shell w) (Prim.shell w) children -- Not a perenant solution! Breaks if can't pack.-pack :: ([Char], [OVal] -> ArgParser (IO [OVal]))+pack :: (String, [OVal] -> ArgParser (IO [OVal])) pack = moduleWithSuite "pack" $ \children -> do example "pack ([45,45], sep=2) { circle(10); circle(10); circle(10); circle(10); }"@@ -448,17 +449,17 @@ putStrLn "Can't pack given objects in given box with present algorithm" return children -unit :: ([Char], [OVal] -> ArgParser (IO [OVal]))+unit :: (String, [OVal] -> ArgParser (IO [OVal])) unit = moduleWithSuite "unit" $ \children -> do example "unit(\"inch\") {..}" -- arguments- unitName :: String <- argument "unit"+ name :: String <- argument "unit" `doc` "the unit you wish to work in" let- mmRatio :: Fractional a => [Char] -> Maybe a+ mmRatio :: Fractional a => String -> Maybe a mmRatio "inch" = Just 25.4 mmRatio "in" = mmRatio "inch" mmRatio "foot" = Just 304.8@@ -476,9 +477,9 @@ mmRatio _ = Nothing -- The actual work...- return $ case mmRatio unitName of+ return $ case mmRatio name of Nothing -> do- putStrLn $ "unrecognized unit " ++ unitName+ putStrLn $ "unrecognized unit " ++ name return children Just r -> return $ objMap (Prim.scale (r,r)) (Prim.scale (r,r,r)) children
Graphics/Implicit/ExtOpenScad/Util/ArgParser.hs view
@@ -8,16 +8,20 @@ -- FIXME: why is this required? {-# LANGUAGE ScopedTypeVariables #-} -module Graphics.Implicit.ExtOpenScad.Util.ArgParser where+module Graphics.Implicit.ExtOpenScad.Util.ArgParser (argument, doc, defaultTo, example, test, eulerCharacteristic, argMap) where -import Prelude(String, Maybe(Just, Nothing), Int, ($), (++), concat, show, error, return, map, snd, filter, (.), fst, foldl1, not, null, (&&))+import Prelude(String, Maybe(Just, Nothing), ($), (++), concat, show, error, return, map, snd, filter, (.), fst, foldl1, not, null, (&&)) import Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch, APTerminator, APFailIf, APExample), OVal (OError), TestInvariant(EulerCharacteristic)) import Graphics.Implicit.ExtOpenScad.Util.OVal (fromOObj, toOObj, OTypeMirror) +import Graphics.Implicit.Definitions(ℕ)+ import qualified Data.Map as Map import Data.Maybe (isNothing, fromJust, isJust) +import Control.Arrow(first)+ -- * ArgParser building functions -- ** argument and combinators@@ -54,9 +58,9 @@ test :: String -> ArgParser () test str = APTest str [] (return ()) -eulerCharacteristic :: ArgParser a -> Int -> ArgParser a+eulerCharacteristic :: ArgParser a -> ℕ -> ArgParser a eulerCharacteristic (APTest str tests child) χ =- APTest str ((EulerCharacteristic χ) : tests) child+ APTest str (EulerCharacteristic χ : tests) child eulerCharacteristic _ _ = error "Impossible!" -- * Tools for handeling ArgParsers@@ -70,7 +74,7 @@ argMap args = argMap2 unnamedArgs (Map.fromList namedArgs) where unnamedArgs = map snd $ filter (isNothing . fst) args- namedArgs = map (\(a,b) -> (fromJust a, b)) $ filter (isJust . fst) args+ namedArgs = map (first fromJust) $ filter (isJust . fst) args argMap2 :: [OVal] -> Map.Map String OVal -> ArgParser a -> (Maybe a, [String])@@ -97,11 +101,7 @@ Nothing -> (Nothing, ["No value and no default for argument " ++ name]) argMap2 a b (APTerminator val) =- (Just val,- if not (null a && Map.null b)- then ["unused arguments"]- else []- )+ (Just val, ["unused arguments" | not (null a && Map.null b)]) argMap2 a b (APFailIf testval err child) = if testval
Graphics/Implicit/ExtOpenScad/Util/OVal.hs view
@@ -3,103 +3,98 @@ -- Released under the GNU AGPLV3+, see LICENSE -- FIXME: required. why?-{-# LANGUAGE ViewPatterns, RankNTypes, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-}--{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-} -module Graphics.Implicit.ExtOpenScad.Util.OVal where+module Graphics.Implicit.ExtOpenScad.Util.OVal(OTypeMirror, (<||>), fromOObj, toOObj, divideObjs, caseOType, oTypeStr, getErrors) where -import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left,Right), String, Char, (==), fromInteger, floor, ($), (.), map, error, (++), show, fromIntegral, head, flip, filter, not, return)+import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left,Right), Char, String, (==), fromInteger, floor, ($), (.), map, error, (++), show, fromIntegral, head, flip, filter, not, return, head) import Graphics.Implicit.Definitions(ℝ, ℕ, SymbolicObj2, SymbolicObj3)+ import Graphics.Implicit.ExtOpenScad.Definitions (OVal(ONum, OBool, OString, OList, OFunc, OUndefined, OModule, OError, OObj2, OObj3))-import qualified Control.Monad as Monad-import Data.Maybe (fromJust, isJust) +import Control.Monad (mapM, msum)++import Data.Maybe (fromMaybe, maybe)+ -- for some minimal paralellism. import Control.Parallel.Strategies(runEval, rpar, rseq) --- | We'd like to be able to turn OVals into a given Haskell type+-- Convert OVals (and Lists of OVals) into a given Haskell type class OTypeMirror a where fromOObj :: OVal -> Maybe a+ fromOObjList :: OVal -> Maybe [a]+ fromOObjList (OList list) = mapM fromOObj list+ fromOObjList _ = Nothing toOObj :: a -> OVal instance OTypeMirror OVal where- fromOObj a = Just a+ fromOObj = Just toOObj a = a instance OTypeMirror ℝ where fromOObj (ONum n) = Just n fromOObj _ = Nothing- toOObj n = ONum n+ toOObj = ONum instance OTypeMirror ℕ where fromOObj (ONum n) = if n == fromInteger (floor n) then Just (floor n) else Nothing fromOObj _ = Nothing- toOObj n = ONum $ fromIntegral n+ toOObj a = ONum $ fromIntegral a instance OTypeMirror Bool where fromOObj (OBool b) = Just b fromOObj _ = Nothing- toOObj b = OBool b+ toOObj = OBool -#if __GLASGOW_HASKELL__ >= 710-instance {-# Overlapping #-} OTypeMirror String where-#else-instance OTypeMirror String where-#endif- fromOObj (OString str) = Just str+-- We don't actually use single chars, this is to compile lists of chars (AKA strings) after passing through OTypeMirror [a]'s fromOObj.+-- This lets us handle strings without overlapping the [a] case.+instance OTypeMirror Char where+ fromOObj (OString str) = Just $ head str fromOObj _ = Nothing- toOObj str = OString str+ fromOObjList (OString str) = Just str+ fromOObjList _ = Nothing+ toOObj a = OString [a] -instance forall a. (OTypeMirror a) => OTypeMirror (Maybe a) where+instance (OTypeMirror a) => OTypeMirror [a] where+ fromOObj = fromOObjList+ toOObj list = OList $ map toOObj list++instance (OTypeMirror a) => OTypeMirror (Maybe a) where fromOObj a = Just $ fromOObj a toOObj (Just a) = toOObj a toOObj Nothing = OUndefined -#if __GLASGOW_HASKELL__ >= 710-instance {-# Overlappable #-} forall a. (OTypeMirror a) => OTypeMirror [a] where-#else-instance forall a. (OTypeMirror a) => OTypeMirror [a] where-#endif- 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)+instance (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):[])) =+instance (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+instance (OTypeMirror a, OTypeMirror b) => OTypeMirror (a -> b) where fromOObj (OFunc f) = Just $ \input -> let oInput = toOObj input oOutput = f oInput output :: Maybe b output = fromOObj oOutput- 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 ++ " )"+ in+ fromMaybe (error $ "coercing OVal to a -> b isn't always safe; use a -> Maybe b"+ ++ " (trace: " ++ show oInput ++ " -> " ++ show oOutput ++ " )") output 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+instance (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@@ -107,8 +102,9 @@ toOObj (Right x) = toOObj x toOObj (Left x) = toOObj x -oTypeStr :: OVal -> [Char]-oTypeStr (OUndefined) = "Undefined"+-- A string representing each type.+oTypeStr :: OVal -> String+oTypeStr OUndefined = "Undefined" oTypeStr (OBool _ ) = "Bool" oTypeStr (ONum _ ) = "Number" oTypeStr (OList _ ) = "List"@@ -121,7 +117,7 @@ getErrors :: OVal -> Maybe String getErrors (OError er) = Just $ head er-getErrors (OList l) = Monad.msum $ map getErrors l+getErrors (OList l) = msum $ map getErrors l getErrors _ = Nothing caseOType :: forall c a. a -> (a -> c) -> c@@ -132,21 +128,20 @@ => (desiredType -> out) -> (OVal -> out) -> (OVal -> out)-(<||>) f g = \input ->+(<||>) f g input = let coerceAttempt :: Maybe desiredType coerceAttempt = fromOObj input in- if isJust coerceAttempt -- ≅ (/= Nothing) but no Eq req- then f $ fromJust coerceAttempt- else g input+ maybe (g input) f coerceAttempt +-- separate 2d and 3d objects from a set of OVals. divideObjs :: [OVal] -> ([SymbolicObj2], [SymbolicObj3], [OVal]) divideObjs children = runEval $ do- obj2s <- rseq ([ x | OObj2 x <- children ])- obj3s <- rseq ([ x | OObj3 x <- children ])- objs <- rpar (filter (not . isOObj) $ children )+ obj2s <- rseq [ x | OObj2 x <- children ]+ obj3s <- rseq [ x | OObj3 x <- children ]+ objs <- rpar (filter (not . isOObj) children) return (obj2s, obj3s, objs) where isOObj (OObj2 _) = True
Graphics/Implicit/ExtOpenScad/Util/StateC.hs view
@@ -7,11 +7,11 @@ -- FIXME: required. why? {-# LANGUAGE KindSignatures, FlexibleContexts #-}-{-# LANGUAGE ViewPatterns, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} module Graphics.Implicit.ExtOpenScad.Util.StateC (getVarLookup, modifyVarLookup, lookupVar, pushVals, getVals, putVals, withPathShiftedBy, getPath, getRelPath, errorC, mapMaybeM, StateC) where -import Prelude(FilePath, IO, String, Maybe(Just, Nothing), Show, Char, Monad, fmap, (.), ($), (++), return, putStrLn, show)+import Prelude(FilePath, IO, String, Maybe(Just, Nothing), Show, Monad, fmap, (.), ($), (++), return, putStrLn, show) import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup, OVal) @@ -20,6 +20,7 @@ import System.FilePath((</>)) import Control.Monad.IO.Class (MonadIO) +-- This is the state machine. It contains the variables, their values, the path, and... ? type CompState = (VarLookup, [OVal], FilePath, (), ()) type StateC = StateT CompState IO @@ -50,7 +51,7 @@ withPathShiftedBy :: FilePath -> StateC a -> StateC a withPathShiftedBy pathShift s = do (a,b,path,d,e) <- get- put (a,b, path </> pathShift, d, e)+ put (a, b, path </> pathShift, d, e) x <- s (a',b',_,d',e') <- get put (a', b', path, d', e')@@ -66,7 +67,7 @@ path <- getPath return $ path </> relPath -errorC :: forall (m :: * -> *) a. (Show a, MonadIO m) => a -> [Char] -> m ()+errorC :: forall (m :: * -> *) a. (Show a, MonadIO m) => a -> String -> m () errorC lineN err = liftIO $ putStrLn $ "At " ++ show lineN ++ ": " ++ err mapMaybeM :: forall t (m :: * -> *) a. Monad m => (t -> m a) -> Maybe t -> m (Maybe a)
Graphics/Implicit/MathUtil.hs view
@@ -9,21 +9,25 @@ module Graphics.Implicit.MathUtil (rmax, rmaximum, rminimum, distFromLineSeg, pack, box3sWithin) where -- Explicitly include what we need from Prelude.-import Prelude (Bool, Num, Ord, Ordering, (>), (<), (+), ($), (/), otherwise, not, (||), (&&), abs, (-), (*), sin, asin, pi, max, sqrt, min, compare, (<=), fst, snd, (++))+import Prelude (Bool, Num, Ord, Ordering, (>), (<), (+), ($), (/), otherwise, not, (||), (&&), abs, (-), (*), sin, asin, pi, max, sqrt, min, compare, (<=), fst, snd, (++), head, flip) import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, Box2, (⋅)) -import Data.List (sort, sortBy, reverse, (!!))+import Data.List (sort, sortBy, (!!))+ import Data.VectorSpace (magnitude, normalized, (^-^), (^+^), (*^))-import Data.AffineSpace ((.-.)) +-- get the distance between two points.+import Data.AffineSpace (distance)+ -- | The distance a point p is from a line segment (a,b) distFromLineSeg :: ℝ2 -> (ℝ2, ℝ2) -> ℝ-distFromLineSeg p (a,b) = magnitude (closest .-. p)+distFromLineSeg p (a,b) = distance p closest where ab = b ^-^ a ap = p ^-^ a d = normalized ab ⋅ ap+ -- the closest point to p on the line segment. closest | d < 0 = a | d > magnitude ab = b@@ -70,26 +74,26 @@ ℝ -- ^ radius -> [ℝ] -- ^ numbers to take round maximum -> ℝ -- ^ resulting number-rmaximum _ (a:[]) = a-rmaximum r (a:b:[]) = rmax r a b+rmaximum _ [a] = a+rmaximum r [a,b] = rmax r a b rmaximum r l = let- tops = reverse $ sort l+ tops = sortBy (flip compare) l in- rmax r (tops !! 0) (tops !! 1)+ rmax r (head tops) (tops !! 1) -- | Like rmin but on a list. rminimum :: ℝ -- ^ radius -> [ℝ] -- ^ numbers to take round minimum -> ℝ -- ^ resulting number-rminimum _ (a:[]) = a-rminimum r (a:b:[]) = rmin r a b+rminimum _ [a] = a+rminimum r [a,b] = rmin r a b rminimum r l = let tops = sort l in- rmin r (tops !! 0) (tops !! 1)+ rmin r (head tops) (tops !! 1) -- | Pack the given objects in a box the given size. pack ::@@ -107,9 +111,9 @@ (\(boxa, _) (boxb, _) -> compareBoxesByY boxa boxb ) objs - tmap1 :: forall t t1 t2. (t2 -> t) -> (t2, t1) -> (t, t1)+ tmap1 :: (t2 -> t) -> (t2, t1) -> (t, t1) tmap1 f (a,b) = (f a, b)- tmap2 :: forall t t1 t2. (t2 -> t1) -> (t, t2) -> (t, t1)+ tmap2 :: (t2 -> t1) -> (t, t2) -> (t, t1) tmap2 f (a,b) = (a, f b) packSome :: [(Box2,a)] -> Box2 -> ([(ℝ2,a)], [(Box2,a)])@@ -121,7 +125,7 @@ packSome otherBoxedObjs ((bx1+x2-x1+sep, by1), (bx2, by1 + y2-y1)) rowAndUp = if abs (by2-by1) - abs (y2-y1) > sep- then tmap1 ((fst row) ++ ) $+ then tmap1 (fst row ++ ) $ packSome (snd row) ((bx1, by1 + y2-y1+sep), (bx2, by2)) else row in
Graphics/Implicit/ObjectUtil/GetBox2.hs view
@@ -2,11 +2,11 @@ -- Copyright 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} module Graphics.Implicit.ObjectUtil.GetBox2 (getBox2, getDist2) where -import Prelude(Bool, Fractional, (==), (||), unzip, minimum, maximum, ($), filter, not, (.), (/), map, (-), (+), (*), cos, sin, sqrt, max, abs, head)+import Prelude(Bool, Fractional, (==), (||), unzip, minimum, maximum, ($), filter, not, (.), (/), map, (-), (+), (*), cos, sin, sqrt, min, max, abs, head) import Graphics.Implicit.Definitions (ℝ, ℝ2, Box2, (⋯*), SymbolicObj2(Shell2, Outset2, Circle, Translate2, Rotate2, UnionR2, Scale2, RectR,@@ -45,8 +45,7 @@ -- Primitives getBox2 (RectR _ a b) = (a,b) getBox2 (Circle r ) = ((-r, -r), (r,r))-getBox2 (PolygonR _ points) = ((minimum xs, minimum ys), (maximum xs, maximum ys))- where (xs, ys) = unzip points+getBox2 (PolygonR _ points) = pointsBox points -- (Rounded) CSG getBox2 (Complement2 _) = ((-infty, -infty), (infty, infty))@@ -79,12 +78,14 @@ getBox2 (Scale2 s symbObj) = let (a,b) = getBox2 symbObj+ (sax, say) = s ⋯* a+ (sbx, sby) = s ⋯* b in- (s ⋯* a, s ⋯* b)+ ((min sax sbx, min say sby), (max sax sbx, max say sby)) getBox2 (Rotate2 θ symbObj) = let ((x1,y1), (x2,y2)) = getBox2 symbObj- rotate (x,y) = (cos(θ)*x - sin(θ)*y, sin(θ)*x + cos(θ)*y)+ rotate (x,y) = (x*cos θ - y*sin θ, x*sin θ + y*cos θ) in pointsBox [ rotate (x1, y1) , rotate (x1, y2)@@ -102,20 +103,26 @@ -- Get the maximum distance (read upper bound) an object is from a point. -- Sort of a circular getDist2 :: ℝ2 -> SymbolicObj2 -> ℝ+-- Real implementations+getDist2 p (Circle r) = magnitude p + r+getDist2 p (PolygonR r points) = r + maximum [magnitude (p ^-^ p') | p' <- points]+-- Transform implementations getDist2 p (UnionR2 r objs) = r + maximum [getDist2 p obj | obj <- objs ]+getDist2 p (DifferenceR2 r objs) = r + (getDist2 p $ head objs)+getDist2 p (IntersectR2 r objs) = r + maximum [getDist2 p obj | obj <- objs ]+-- FIXME: isn't this wrong? should we be returning distance inside of the object?+getDist2 _ (Complement2 _) = 1/0 getDist2 p (Translate2 v obj) = getDist2 (p ^+^ v) obj-getDist2 p (Circle r) = magnitude p + r-getDist2 p (PolygonR r points) =- r + maximum [magnitude (p ^-^ p') | p' <- points] -- FIXME: write optimized functions for the rest of the SymbObjs.+-- Fallthrough: use getBox2 to check the distance a box is from the point. getDist2 (x,y) symbObj = let ((x1,y1), (x2,y2)) = getBox2 symbObj in sqrt (- (max (abs (x1 - x)) (abs (x2 - x))) *- (max (abs (x1 - x)) (abs (x2 - x))) +- (max (abs (y1 - y)) (abs (y2 - y))) *- (max (abs (y1 - y)) (abs (y2 - y)))+ max (abs (x1 - x)) (abs (x2 - x)) *+ max (abs (x1 - x)) (abs (x2 - x)) ++ max (abs (y1 - y)) (abs (y2 - y)) *+ max (abs (y1 - y)) (abs (y2 - y)) )
Graphics/Implicit/ObjectUtil/GetBox3.hs view
@@ -4,11 +4,11 @@ -- Released under the GNU AGPLV3+, see LICENSE -- FIXME: required. why?-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-} module Graphics.Implicit.ObjectUtil.GetBox3 (getBox3) where -import Prelude(Eq, Bool(False), Fractional, Either (Left, Right), Maybe(Nothing, Just), (==), (||), max, (/), (-), (+), map, unzip, ($), filter, not, (.), unzip3, minimum, maximum, min, sqrt, (>), (&&), head, (*), (<), abs, either, error, const)+import Prelude(Eq, Bool(False), Fractional, Either (Left, Right), Maybe(Nothing, Just), (==), (||), max, (/), (-), (+), map, unzip, ($), filter, not, (.), unzip3, minimum, maximum, min, sqrt, (>), (&&), head, (*), (<), abs, either, error, const, otherwise) import Graphics.Implicit.Definitions (ℝ, Box3, SymbolicObj3 (Rect3R, Sphere, Cylinder, Complement3, UnionR3, IntersectR3, DifferenceR3, Translate3, Scale3, Rotate3, Rotate3V, Shell3, Outset3, EmbedBoxedObj3, ExtrudeR, ExtrudeOnEdgeOf, ExtrudeRM, RotateExtrude, ExtrudeRotateR), (⋯*)) import Graphics.Implicit.ObjectUtil.GetBox2 (getBox2, getDist2)@@ -29,7 +29,7 @@ getBox3 :: SymbolicObj3 -> Box3 -- Primitives getBox3 (Rect3R _ a b) = (a,b)-getBox3 (Sphere r ) = ((-r, -r, -r), (r,r,r))+getBox3 (Sphere r) = ((-r, -r, -r), (r,r,r)) getBox3 (Cylinder h r1 r2) = ( (-r,-r,0), (r,r,h) ) where r = max r1 r2 -- (Rounded) CSG getBox3 (Complement3 _) =@@ -77,12 +77,14 @@ getBox3 (Scale3 s symbObj) = let (a,b) = getBox3 symbObj+ (sax,say,saz) = s ⋯* a+ (sbx,sby,sbz) = s ⋯* b in- (s ⋯* a, s ⋯* b)+ ((min sax sbx, min say sby, min saz sbz), (max sax sbx, max say sby, max saz sbz)) getBox3 (Rotate3 _ symbObj) = ( (-d, -d, -d), (d, d, d) ) where ((x1,y1, z1), (x2,y2, z2)) = getBox3 symbObj- d = (sqrt 3 *) $ maximum $ map abs [x1, x2, y1, y2, z1, z2]+ 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) =@@ -108,7 +110,7 @@ range = [0, 0.1 .. 1.0] ((x1,y1),(x2,y2)) = getBox2 symbObj (dx,dy) = (x2 - x1, y2 - y1)- (xrange, yrange) = (map (\s -> x1+s*dx) $ range, map (\s -> y1+s*dy) $ range )+ (xrange, yrange) = (map (\s -> x1+s*dx) range, map (\s -> y1+s*dy) range ) h = case eitherh of Left h' -> h'@@ -116,7 +118,7 @@ where hs = [hf (x,y) | x <- xrange, y <- yrange] (hmin, hmax) = (minimum hs, maximum hs)- hrange = map (h*) $ range+ hrange = map (h*) range sval = case scale of Nothing -> 1 Just scale' -> maximum $ map (abs . scale') hrange@@ -141,6 +143,7 @@ r = max x2 (x2 + xshift) in ((-r, -r, min y1 (y1 + yshift)),(r, r, max y2 (y2 + yshift)))+-- FIXME: magic numbers getBox3 (RotateExtrude rot _ (Right f) rotate symbObj) = let ((x1,y1),(x2,y2)) = getBox2 symbObj@@ -148,7 +151,9 @@ 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+ xmax' | xmax > 0 = xmax * 1.1+ | xmax < - x1 = 0+ | otherwise = xmax ymax' = ymax + 0.1 * (ymax - ymin) ymin' = ymin - 0.1 * (ymax - ymin) (r, _, _) = if either (==0) (const False) rotate@@ -159,4 +164,4 @@ in ((-r, -r, y1 + ymin'),(r, r, y2 + ymax')) -- FIXME: add case for ExtrudeRotateR!-getBox3(ExtrudeRotateR _ _ _ _ ) = error "ExtrudeRotateR implementation incomplete!"+getBox3 ExtrudeRotateR{} = error "ExtrudeRotateR implementation incomplete!"
Graphics/Implicit/ObjectUtil/GetImplicit2.hs view
@@ -10,9 +10,10 @@ module Graphics.Implicit.ObjectUtil.GetImplicit2 (getImplicit2) where -import Prelude(Int, Num, abs, (-), (/), sqrt, (*), (+), (!!), mod, length, map, (<=), (&&), (>=), (||), odd, ($), (>), filter, (<), minimum, (==), maximum, max, cos, sin, head, tail)+import Prelude(Num, abs, (-), (/), sqrt, (*), (+), (!!), mod, length, map, (<=), (&&), (>=), (||), odd, ($), (>), filter, (<), minimum, (==), maximum, max, cos, sin, head, tail, (.)) -import Graphics.Implicit.Definitions (SymbolicObj2(RectR, Circle, PolygonR, Complement2, UnionR2, DifferenceR2, IntersectR2, Translate2, Scale2, Rotate2, Shell2, Outset2, EmbedBoxedObj2), Obj2, ℝ, ℝ2, (⋯/))+import Graphics.Implicit.Definitions (ℝ, Fastℕ, ℝ2, (⋯/), Obj2, SymbolicObj2(RectR, Circle, PolygonR, Complement2, UnionR2, DifferenceR2, IntersectR2, Translate2, Scale2, Rotate2, Shell2, Outset2, EmbedBoxedObj2))+ import Graphics.Implicit.MathUtil (rminimum, rmaximum, distFromLineSeg) import Data.VectorSpace ((^-^))@@ -20,83 +21,89 @@ getImplicit2 :: SymbolicObj2 -> Obj2 -- Primitives-getImplicit2 (RectR r (x1,y1) (x2,y2)) = \(x,y) -> rmaximum r- [abs (x-dx/2-x1) - dx/2, abs (y-dy/2-y1) - dy/2]- where (dx, dy) = (x2-x1, y2-y1)-getImplicit2 (Circle r ) =+getImplicit2 (RectR r (x1,y1) (x2,y2)) =+ \(x,y) -> let+ (dx, dy) = (x2-x1, y2-y1)+ in+ if r == 0+ then maximum [abs (x-dx/2-x1) - dx/2, abs (y-dy/2-y1) - dy/2]+ else rmaximum r [abs (x-dx/2-x1) - dx/2, abs (y-dy/2-y1) - dy/2]+getImplicit2 (Circle r) = \(x,y) -> sqrt (x * x + y * y) - r getImplicit2 (PolygonR _ points) = \p -> let- pair :: Int -> (ℝ2,ℝ2)- pair n = (points !! n, points !! (mod (n + 1) (length points) ) )- pairs = [ pair n | n <- [0 .. (length points) - 1] ]+ pair :: Fastℕ -> (ℝ2,ℝ2)+ pair n = (points !! n, points !! mod (n + 1) (length points) )+ pairs = [ pair n | n <- [0 .. length points - 1] ] relativePairs = map (\(a,b) -> (a ^-^ p, b ^-^ p) ) pairs crossing_points = [x2 ^-^ y2*(x2-x1)/(y2-y1) | ((x1,y1), (x2,y2)) <-relativePairs, ( (y2 <= 0) && (y1 >= 0) ) || ( (y2 >= 0) && (y1 <= 0) ) ]- seemsInRight = odd $ length $ filter (>0) $ nub crossing_points- seemsInLeft = odd $ length $ filter (<0) $ nub crossing_points+ -- FIXME: use partition instead?+ seemsInRight = odd . length . filter (>0) $ nub crossing_points+ seemsInLeft = odd . length . filter (<0) $ nub crossing_points isIn = seemsInRight && seemsInLeft dists = map (distFromLineSeg p) pairs :: [ℝ] in minimum dists * if isIn then -1 else 1 -- (Rounded) CSG getImplicit2 (Complement2 symbObj) =- let+ \p -> let obj = getImplicit2 symbObj in- \p -> - obj p+ - obj p getImplicit2 (UnionR2 r symbObjs) =- let+ \p -> let objs = map getImplicit2 symbObjs in if r == 0- then \p -> minimum $ map ($p) objs- else \p -> rminimum r $ map ($p) objs+ then minimum $ map ($p) objs+ else rminimum r $ map ($p) objs getImplicit2 (DifferenceR2 r symbObjs) = let objs = map getImplicit2 symbObjs obj = head objs complement :: forall a t. Num a => (t -> a) -> t -> a- complement obj' = \p -> - obj' p+ complement obj' p = - obj' p in if r == 0- then \p -> maximum $ map ($p) $ obj:(map complement $ tail objs)- else \p -> rmaximum r $ map ($p) $ obj:(map complement $ tail objs)+ then \p -> maximum . map ($p) $ obj:map complement (tail objs)+ else \p -> rmaximum r . map ($p) $ obj:map complement (tail objs) getImplicit2 (IntersectR2 r symbObjs) =- let+ \p -> let objs = map getImplicit2 symbObjs in if r == 0- then \p -> maximum $ map ($p) objs- else \p -> rmaximum r $ map ($p) objs+ then maximum $ map ($p) objs+ else rmaximum r $ map ($p) objs -- Simple transforms getImplicit2 (Translate2 v symbObj) =- let+ \p -> let obj = getImplicit2 symbObj in- \p -> obj (p ^-^ v)+ obj (p ^-^ v) getImplicit2 (Scale2 s@(sx,sy) symbObj) =- let+ \p -> let obj = getImplicit2 symbObj+ k = abs(max sx sy) in- \p -> (max sx sy) * obj (p ⋯/ s)+ k * obj (p ⋯/ s) getImplicit2 (Rotate2 θ symbObj) =- let+ \(x,y) -> let obj = getImplicit2 symbObj in- \(x,y) -> obj ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x)+ obj ( x*cos θ + y*sin θ, y*cos θ - x*sin θ) -- Boundary mods getImplicit2 (Shell2 w symbObj) =- let+ \p -> let obj = getImplicit2 symbObj in- \p -> abs (obj p) - w/2+ abs (obj p) - w/2 getImplicit2 (Outset2 d symbObj) =- let+ \p -> let obj = getImplicit2 symbObj in- \p -> obj p - d+ obj p - d -- Misc getImplicit2 (EmbedBoxedObj2 (obj,_)) = obj
Graphics/Implicit/ObjectUtil/GetImplicit3.hs view
@@ -8,9 +8,9 @@ module Graphics.Implicit.ObjectUtil.GetImplicit3 (getImplicit3) where -import Prelude (Either(Left, Right), Int, abs, (-), (/), (*), sqrt, (+), atan2, max, cos, map, (==), minimum, ($), maximum, (**), sin, const, pi, (.), Bool(True, False), ceiling, floor, fromIntegral, return, error, head, tail, Num)+import Prelude (Either(Left, Right), abs, (-), (/), (*), sqrt, (+), atan2, max, cos, map, (==), minimum, ($), maximum, (**), sin, const, pi, (.), Bool(True, False), ceiling, floor, fromIntegral, return, error, head, tail, Num) -import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, (⋯/), Obj3,+import Graphics.Implicit.Definitions (ℝ, Fastℕ, ℝ2, ℝ3, (⋯/), Obj3, SymbolicObj3(Shell3, UnionR3, IntersectR3, DifferenceR3, Translate3, Scale3, Rotate3, Outset3, Rect3R, Sphere, Cylinder, Complement3, EmbedBoxedObj3, Rotate3V, ExtrudeR, ExtrudeRM, ExtrudeOnEdgeOf, RotateExtrude, ExtrudeRotateR))@@ -19,13 +19,15 @@ import qualified Data.Either as Either import Data.VectorSpace ((^-^), (^+^), (^*), (<.>), normalized) +-- Use getImplicit2 for handling extrusion of 2D shapes to 3D. import Graphics.Implicit.ObjectUtil.GetImplicit2 (getImplicit2) getImplicit3 :: SymbolicObj3 -> Obj3 -- Primitives-getImplicit3 (Rect3R r (x1,y1,z1) (x2,y2,z2)) = \(x,y,z) -> rmaximum r- [abs (x-dx/2-x1) - dx/2, abs (y-dy/2-y1) - dy/2, abs (z-dz/2-z1) - dz/2]- where (dx, dy, dz) = (x2-x1, y2-y1, z2-z1)+getImplicit3 (Rect3R r (x1,y1,z1) (x2,y2,z2)) =+ \(x,y,z) -> let (dx, dy, dz) = (x2-x1, y2-y1, z2-z1)+ in+ rmaximum r [abs (x-dx/2-x1) - dx/2, abs (y-dy/2-y1) - dy/2, abs (z-dz/2-z1) - dz/2] getImplicit3 (Sphere r ) = \(x,y,z) -> sqrt (x*x + y*y + z*z) - r getImplicit3 (Cylinder h r1 r2) = \(x,y,z) ->@@ -59,11 +61,11 @@ objs = map getImplicit3 symbObjs obj = head objs complement :: forall a t. Num a => (t -> a) -> t -> a- complement obj' = \p -> - obj' p+ complement obj' p = - obj' p in if r == 0- then \p -> maximum $ map ($p) $ obj:(map complement $ tail objs)- else \p -> rmaximum r $ map ($p) $ obj:(map complement $ tail objs)+ then \p -> maximum $ map ($p) $ obj:map complement (tail objs)+ else \p -> rmaximum r $ map ($p) $ obj:map complement (tail objs) -- Simple transforms getImplicit3 (Translate3 v symbObj) = let@@ -73,20 +75,20 @@ getImplicit3 (Scale3 s@(sx,sy,sz) symbObj) = let obj = getImplicit3 symbObj- k = (sx*sy*sz)**(1/3)+ k = abs(sx*sy*sz)**(1/3) in \p -> k * obj (p ⋯/ s) getImplicit3 (Rotate3 (yz, zx, xy) symbObj) = let obj = getImplicit3 symbObj rotateYZ :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)- rotateYZ θ obj' = \(x,y,z) -> obj' ( x, cos(θ)*y + sin(θ)*z, cos(θ)*z - sin(θ)*y)+ rotateYZ θ obj' (x,y,z) = obj' ( x, y*cos θ + z*sin θ, z*cos θ - y*sin θ) rotateZX :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)- rotateZX θ obj' = \(x,y,z) -> obj' ( cos(θ)*x - sin(θ)*z, y, cos(θ)*z + sin(θ)*x)+ rotateZX θ obj' (x,y,z) = obj' ( x*cos θ - z*sin θ, y, z*cos θ + x*sin θ) rotateXY :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)- rotateXY θ obj' = \(x,y,z) -> obj' ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x, z)+ rotateXY θ obj' (x,y,z) = obj' ( x*cos θ + y*sin θ, y*cos θ - x*sin θ, z) in- rotateYZ yz $ rotateZX zx $ rotateXY xy $ obj+ rotateYZ yz . rotateZX zx $ rotateXY xy obj getImplicit3 (Rotate3V θ axis symbObj) = let axis' = normalized axis@@ -98,9 +100,9 @@ , ax * by - ay * bx ) in \v -> obj $- v ^* cos(θ)- ^-^ (axis' `cross3` v) ^* sin(θ)- ^+^ (axis' ^* (axis' <.> (v ^* (1 - cos(θ)))))+ v ^* cos θ+ ^-^ (axis' `cross3` v) ^* sin θ+ ^+^ (axis' ^* (axis' <.> (v ^* (1 - cos θ)))) -- Boundary mods getImplicit3 (Shell3 w symbObj) = let@@ -130,9 +132,9 @@ Left n -> n Right f -> f (x,y) scaleVec :: ℝ -> ℝ2 -> ℝ2- scaleVec s = \(x,y) -> (x/s, y/s)+ scaleVec s (x,y) = (x/s, y/s) rotateVec :: ℝ -> ℝ2 -> ℝ2- rotateVec θ (x,y) = (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ))+ rotateVec θ (x,y) = (x*cos θ + y*sin θ, y*cos θ - x*sin θ) k = (pi :: ℝ)/(180:: ℝ) in \(x,y,z) -> let h = height' (x,y) in@@ -157,12 +159,12 @@ round' = Maybe.fromMaybe 0 round translate' :: ℝ -> ℝ2 translate' = Either.either- (\(a,b) -> \θ -> (a*θ/totalRotation', b*θ/totalRotation'))+ (\(a,b) θ -> (a*θ/totalRotation', b*θ/totalRotation')) (. (/k)) translate rotate' :: ℝ -> ℝ rotate' = Either.either- (\t -> \θ -> t*θ/totalRotation' )+ (\t θ -> t*θ/totalRotation' ) (. (/k)) rotate twists = case rotate of@@ -174,13 +176,13 @@ let r = sqrt (x*x + y*y) θ = atan2 y x- ns :: [Int]+ ns :: [Fastℕ] ns = if capped then -- we will cap a different way, but want leeway to keep the function cont- [-1 .. (ceiling (totalRotation' / tau)) + 1]+ [-1 .. ceiling (totalRotation' / tau) + 1] else- [0 .. floor $ (totalRotation' - θ) /tau]+ [0 .. floor $ (totalRotation' - θ) / tau] n <- ns let θvirt = fromIntegral n * tau + θ@@ -201,4 +203,4 @@ else obj rz_pos -- FIXME: implement this, or implement a fallthrough function. --getImplicit3 (ExtrudeRotateR) =-getImplicit3 (ExtrudeRotateR _ _ _ _) = error "ExtrudeRotateR unimplimented!"+getImplicit3 ExtrudeRotateR{} = error "ExtrudeRotateR unimplimented!"
+ Makefile view
@@ -0,0 +1,78 @@+.PHONY: build install clean docs dist test examples tests++RTSOPTS=+RTS -N++RESOPTS=-r 50++#uncomment for profiling support.+#PROFILING= --enable-library-profiling --enable-executable-profiling++# stl2ps, from stltools, available from https://github.com/rsmith-nl/stltools/tree/develop+stl2ps=/disk4/faikvm.com/stltools/stltools/stl2ps.py++# convert, from imagemagick+convert=convert++EXTOPENSCAD=dist/build/extopenscad/extopenscad+TESTSUITE=dist/build/test-implicit/test-implicit+TARGETS=$(EXTOPENSCAD) $(TESTSUITE)++# FIXME: this used to be ./Setup install. what's going on?+install: $(TARGETS)+ cabal install++clean: Setup+ ./Setup clean+ rm -f Examples/*.stl+ rm -f Examples/*.svg+ rm -f Examples/*.ps+ rm -f Examples/*.png+ rm -f Examples/example[0-9][0-9]+ rm -f Examples/*.hi+ rm -f Examples/*.o+ rm -f tests/*.stl+ rm -f Setup Setup.hi Setup.o+ rm -rf dist/*++distclean: clean+ rm -f `find ./ -name *~`+ rm -f `find ./ -name \#*\#`++nukeclean: distclean+ rm -rf ~/.cabal/ ~/.ghc/+++docs: $(TARGETS)+ ./Setup haddock++dist: $(TARGETS)+ ./Setup sdist++#test: $(TARGETS)+# ./Setup test++examples: $(TARGETS)+ cd Examples && for each in `find ./ -name '*scad' -type f | sort`; do { valgrind --tool=cachegrind --cachegrind-out-file=$$each.cachegrind.`date +%s` ../$(EXTOPENSCAD) $$each ${RTSOPTS}; } done+ cd Examples && for each in `find ./ -name '*.hs' -type f | sort`; do { filename=$(basename "$$each"); filename="$${filename%.*}"; ghc $$filename.hs -o $$filename; $$filename; } done++images:+ cd Examples && for each in `find ./ -name '*.stl' -type f | sort`; do { filename=$(basename "$$each"); filename="$${filename%.*}"; if [ -e $$filename.transform ] ; then echo ${stl2ps} $$each $$filename.ps `cat $$filename.transform`; else ${stl2ps} $$each $$filename.ps; fi; ${convert} $$filename.ps $$filename.png; } done++tests: $(TARGETS)+# cd tests && for each in `find ./ -name '*scad' -type f | sort`; do { ../$(EXTOPENSCAD) $$each ${RESOPTS} ${RTSOPTS}; } done+ ./dist/build/test-implicit/test-implicit++dist/build/extopenscad/extopenscad: Setup dist/setup-config+ cabal build++dist/build/test-implicit/test-implicit: Setup dist/setup-config+ cabal build++dist/setup-config: Setup implicit.cabal+ cabal update+ cabal install --only-dependencies --upgrade-dependencies+ cabal configure --enable-tests $(PROFILING)++Setup: Setup.*hs+ ghc -O2 -Wall --make Setup+
+ README.md view
@@ -0,0 +1,312 @@+ImplicitCAD: Math Inspired CAD+==============================++Introduction+------------++ImplicitCAD is a programmatic CAD program, implemented in haskell. Unlike traditional CAD programs, programmatic CAD programs use text descriptions of objects, as in programming. Concepts like variables, control structures and abstraction are used, just as in programming. This provides a number of advantages:++ - Objects can be abstracted and reused+ - Repetitive tasks can be automated+ - Objects can be designed parametrically+ - The usual tools for software development (like version control) can be used++The traditional example of programmatic CAD is OpenSCAD.++Generally, objects in programmatic CAD are built with Constructive Solid Geometry or CSG. Unions, intersections and differences of simpler shapes slowly build the object. ImplicitCAD supports all this and much more! For example, it provides rounded unions so that one can have smooth interfaces between objects.++It also directly provides some GCode generation, and has a parser for OpenSCAD to make it easier for people to transition/use.++ImplicitCAD is very much a work in progress. The author considers it ready for beta testers and greatly appreciates bug reports.+++ExtOpenSCAD Examples+--------------------++Let's begin with OpenSCAD examples, since they're likely a more comfortable format than Haskell for most readers :)++ImplicitCAD supports a modified version of the OpenSCAD language, used by the popular programmatic CAD tool of the same name.++Generally, normal OpenSCAD code should work. For example, save the following as `example1.scad` (or grab it out of the Examples/ directory shipped with ImplicitCAD).++```c+// example1.scad -- The union of a square and a circle.+union() {+ square([80,80]);+ translate ([80,80]) circle(30);+}+```++Running `extopenscad example1.scad` will produce `example1.svg`, which will look like:++++You can read more about standard openscad functionality in the [OpenSCAD User Manual](http://en.wikibooks.org/wiki/OpenSCAD_User_Manual).++However, there are additional ImplicitCAD specific features. For example a rounded union:++```c+//example2.escad -- A rounded union of a square and a circle.+union(r=14) {+ square([80,80]);+ translate ([80,80]) circle(30);+}+```++++(For code like this that is not backwards compatible with OpenSCAD, it is recommended that you save it as a .escad file -- Extended OpenSCAD.)++Like openscad, ImplicitCAD supports extruding objects.++```c+// example3.escad -- the extruded product of the union of five circles.+linear_extrude (height = 40, center=true){+ union ( r = 8) {+ circle (10);+ translate ([22,0]) circle (10);+ translate ([0,22]) circle (10);+ translate ([-22,0]) circle (10);+ translate ([0,-22]) circle (10);+ }+}+```++++And we allow you to twist them as you extrude.+++```c+// example4.escad -- the twisted extruded product of the union of five circles.+linear_extrude (height = 40, center=true, twist=90){+ union ( r = 8) {+ circle (10);+ translate ([22,0]) circle (10);+ translate ([0,22]) circle (10);+ translate ([-22,0]) circle (10);+ translate ([0,-22]) circle (10);+ }+}+```++++In fact, we've extended this to allow you to twist at non-constant rates and even reverse directions. You just make `twist` a function! (We're following the openscad convention of using degrees...)++```c+// example5.escad -- the variably twisted extruded product of the union of 5 circles.+linear_extrude (height = 40, center=true, twist(h) = 35*cos(h*2*pi/60)) {+ union ( r = 8) {+ circle (10);+ translate ([22,0]) circle (10);+ translate ([0,22]) circle (10);+ translate ([-22,0]) circle (10);+ translate ([0,-22]) circle (10);+ }+}+```++++We also allow you to do rounded extrusions. See, we heard you like rounding, so we set this up so you can rounded extrude your rounded union...++```c+// example6.escad -- A rounded extrusion of the rounded union of 5 circles.+linear_extrude (height = 40, center=true, r=5){+ union ( r = 8) {+ circle (10);+ translate ([22,0]) circle (10);+ translate ([0,22]) circle (10);+ translate ([-22,0]) circle (10);+ translate ([0,-22]) circle (10);+ }+}+```++++This is fully compatible with twisting, of course!++```c+// example7.escad -- A twisted rounded extrusion of the rounded union of 5 circles.+linear_extrude (height = 40, center=true, twist=90, r=5){+ union ( r = 8) {+ circle (10);+ translate ([22,0]) circle (10);+ translate ([0,22]) circle (10);+ translate ([-22,0]) circle (10);+ translate ([0,-22]) circle (10);+ }+}+```+++++ImplicitCAD also provides full programmatic functionality, like variable assignment in loops, which are sadly absent in OpenSCAD. For example, the trivial program:++```c+// Example8.escad -- variable assignment in loops.+a = 5;+for (c = [1, 2, 3]) {+ echo(c);+ a = a*c;+ echo(a);+}+```++Has the output:+++```+1.0+5.0+2.0+10.0+3.0+30.0+Nothing to render+```++As a functional programmer, I couldn't resist adding some other niceties to the language. For example, function currying:++```c+// Example9.escad -- function currying.+f = max(4);+echo(f(5));+echo(max(4,5));+```+And some higher order functions, like my friend map:++```c+// Example10.escad -- map!.+echo(map(cos, [0, pi/2, pi]));+```++Haskell Examples+-----------------++Everything you saw above can be done with the Haskell API. For example, a simple 2D example, the same as our first ExtOpenSCAD one:++```haskell+-- Example 11 - the union of a square and a circle.+import Graphics.Implicit++out = union [+ rectR 0 (-40,-40) (40,40),+ translate (40,40) (circle 30) ]++main = writeSVG 2 "test.svg" out+```+++++A rounded union:++```haskell+-- Example 12 - the rounded union of a square and a circle.+import Graphics.Implicit++out = unionR 14 [+ rectR 0 (-40,-40) (40,40),+ translate (40,40) (circle 30) ]++main = writeSVG 2 "test.svg" out+```++++A simple 3D example:++```haskell+-- Example 13 - the union of a cube and a sphere.+import Graphics.Implicit++out = union [+ rect3R 0 (0,0,0) (20,20,20),+ translate (20,20,20) (sphere 15) ]++main = writeSTL 1 "test.stl" out+```++++You can do a whole lot more!++Try ImplicitCAD!+----------------++ 1. Install GHC and cabal.+ * Debain/Ubuntu: `apt-get install ghc cabal-install zlib1g-dev`+ * Archlinux: `pacman -S ghc cabal-install`+ * Red Hat/Fedora: `yum install ghc cabal-install`+ * Mac OSX:+ * Homebrew: `brew install ghc cabal-install`+ * *Fink doesn't seem to have a package for cabal*; Install the Haskell Platform [manually](http://hackage.haskell.org/platform/mac.html).+ * Windows: Follows [these install instructions](http://hackage.haskell.org/platform/windows.html).+ * Other unices: If your package manager does not include ghc and cabal you should [install the Haskell platform](http://www.haskell.org/platform).+ 2. You now have two options for installation:+ * Latest release:+ * Use cabal to install ImplicitCAD: `cabal update && cabal install implicit`+ * Development version:+ * Initialize your haskell environment: `cabal update`+ * Git clone this repo: `git clone https://github.com/colah/ImplicitCAD.git`+ * cd in: `cd ImplicitCAD/`+ * install the dependencies: `cabal configure && cabal install --only-dependencies`+ * The previous step may fail, but it should tell you what's missing.+ * try to 'cabal install' each of the things it tells you are missing.+ * Finally, cabal install implicitcad: `cabal install`+ 3. Try it!+ * extopenscad test:+ * Make a test file: `echo "circle(30);" > test.escad`+ * Run extopencad: `extopenscad test.escad`+ * Alternatively, `~/.cabal/bin/extopenscad test.escad` -- see bellow.+ * Haskell ImplicitCAD test:+ * Start ghci: `ghci`+ * Load ImplicitCAD: `import Graphics.Implicit`+ * Try it! `writeSVG 1 "test.svg" (circle 30)`+ 4. Known issues:+ * extopenscad test results in `bash: extopenscad: command not found` (or similar for your shell)+ * This probably means `~/.cabal/bin/` is not in your `$PATH` variable.+ Try using `~/.cabal/bin/extopenscad` as your command instead.+ * Haskell test results in `module is not loaded: 'Graphics.Implicit' (./Graphics/Implicit.hs)`+ * This is most likely a problem with your Linux distro and cabal not playing nice.+ GHC is not configured to see the ImplicitCAD libraries. You can confirm this by+ trying the test in `~/.cabal/lib/`. If that works, you should be able to use ghc+ anywhere with the `-Ldir` or `-llib` options. Alternatively, some people have+ permanently fixed this by doing the cabal install as root.++Documentation+-------------++Documentation can be generated from the source code of ImplicitCAD by Haddock by running `cabal haddock`.++Releases of ImplicitCAD are uploaded to HackageDB which, in addition to making them avaialable through `cabal install`, puts the generated documentation on the Internet. So you can read the documentation for the most recent release of ImplicitCAD, 0.0.1, [on HackageDB](http://hackage.haskell.org/packages/archive/implicit/0.0.3/doc/html/Graphics-Implicit.html) (for some reason the latest version doesn't seem to have built).++In Implicit CAD, we consider objects as functions of `outwardness'. The boundary is 0, negative is the interior and positive the exterior. The magnitude is how far out or in. A description of the mathematical ideas underpinning ImplicitCAD are in a [blog post on colah's blog](http://christopherolah.wordpress.com/2011/11/06/manipulation-of-implicit-functions-with-an-eye-on-cad/). Note that substantial changes have happened since that post. You can also look at the [0.0.3 relase notes](http://christopherolah.wordpress.com/2012/02/06/implicitcad-0-0-3-release/).++Status+------++ImplicitCAD is very much a work in progress.++What works (July 31, 2015 -- regressions are possible if not probable):++ - CSG, bevelled CSG, shells.+ - 2D output (svg).+ - 3D output (stl).+ - gcode generation for 2D to hacklab laser cutter. Not configurable.++What still needs to be done:++ - gcode generation for 3D printers, gcode generator config.+ - openscad parser for backwards compatibility (partially complete).++And a wishlist of things further in the future:++ - More optimisation.+ - Less bugs.+ - openGL viewer?+ - openCL acceleration?
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+main :: IO () main = defaultMain
− bench/ParserBench.hs
@@ -1,61 +0,0 @@-import Criterion.Main-import Graphics.Implicit.ExtOpenScad.Definitions-import Graphics.Implicit.ExtOpenScad.Parser.Expr-import Graphics.Implicit.ExtOpenScad.Parser.Statement-import Text.ParserCombinators.Parsec hiding (State)-import Text.Printf--lineComment :: Int -> String-lineComment width = "//" ++ ['x' | _ <- [1..width]] ++ "\n"--lineComments :: Int -> String-lineComments n = concat [lineComment 80 | _ <- [1..n]]- ++ assignments 1 -- to avoid empty file--blockComment :: Int -> Int -> String-blockComment lineCount width =- "/*" ++ concat [['x' | _ <- [1..width]] ++ "\n" | _ <- [1..lineCount]] ++ "*/"--blockComments :: Int -> Int -> String-blockComments lineCount n = concat [blockComment lineCount 40 | _ <- [1..n]]- ++ assignments 1 -- to avoid empty file--assignments :: Int -> String-assignments n = concat ["x = (foo + bar);\n" | _ <- [1..n]]--intList :: Int -> String-intList n = "[" ++ concat [(show i) ++ "," | i <- [1..n]] ++ "0]"--parseExpr :: String -> Expr-parseExpr s = case parse expr0 "src" s of- Left err -> error (show err)- Right e -> e--parseStatements :: String -> [StatementI]-parseStatements s = case parseProgram "src" s of- Left err -> error (show err)- Right e -> e--deepArithmetic :: Int -> String-deepArithmetic n- | n == 0 = "1"- | otherwise = printf "%s + %s * (%s - %s)" d d d d- where- d = deepArithmetic (n - 1)--run :: String -> (String -> a) -> String -> Benchmark-run name func input =- env (return $ input) $ \s ->- bench name $ whnf func s--main :: IO ()-main =- defaultMain $- [ bgroup "comments"- [ run "line" parseStatements (lineComments 5000)- , run "block" parseStatements (blockComments 10 500)- ]- , run "assignments" parseStatements (assignments 100)- , run "int list" parseExpr (intList 1000)- , run "deep arithmetic" parseExpr (deepArithmetic 3)- ]
+ docgen.hs view
@@ -0,0 +1,88 @@+-- 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 #-}++-- FIXME: this doesn't work. looks like it broke badly when ArgParser became a Monad.++import Graphics.Implicit.ExtOpenScad.Primitives (primitives)+import Graphics.Implicit.ExtOpenScad.Util.ArgParser++import Control.Monad++isExample (ExampleDoc _ ) = True+isExample _ = False++isArgument (ArgumentDoc _ _ _) = True+isArgument _ = False++main = do+ let names = map fst primitives+ docs <- sequence $ map (getArgParserDocs.($ []).snd) primitives++ forM_ (zip names docs) $ \(moduleName, moduleDocList) -> do+ let+ examples = filter isExample moduleDocList+ arguments = filter isArgument moduleDocList+ putStrLn moduleName+ putStrLn (map (const '-') moduleName)+ putStrLn ""+ if not $ null examples then putStrLn "**Examples:**\n" else return ()+ forM_ examples $ \(ExampleDoc example) -> do+ putStrLn $ " * `" ++ example ++ "`"+ putStrLn ""+ putStrLn "**Arguments:**\n"+ forM_ arguments $ \(ArgumentDoc name posfallback description) ->+ case (posfallback, description) of+ (Nothing, "") -> do+ putStrLn $ " * `" ++ name ++ "`"+ (Just fallback, "") -> do+ putStrLn $ " * `" ++ name ++ " = " ++ fallback ++ "`"+ (Nothing, _) -> do+ putStrLn $ " * `" ++ name ++ "`"+ putStrLn $ " " ++ description+ (Just fallback, _) -> do+ putStrLn $ " * `" ++ name ++ " = " ++ fallback ++ "`"+ putStrLn $ " " ++ description+ putStrLn ""++-- | We need a format to extract documentation into+data Doc = Doc String [DocPart]+ deriving (Show)++data DocPart = ExampleDoc String+ | ArgumentDoc String (Maybe String) String+ deriving (Show)+++-- Here there be dragons!+-- Because we made this a Monad instead of applicative functor, there's now sane way to do this.+-- We give undefined (= an error) and let laziness prevent if from ever being touched.+-- We're using IO so that we can catch an error if this backfires.+-- If so, we *back off*.++-- | Extract Documentation from an ArgParser++getArgParserDocs ::+ (ArgParser a) -- ^ ArgParser+ -> IO [DocPart] -- ^ Docs (sadly IO wrapped)++getArgParserDocs (ArgParser name fallback doc fnext) =+ do+ otherDocs <- Ex.catch (getArgParserDocs $ fnext undefined) (\(e :: Ex.SomeException) -> return [])+ return $ (ArgumentDoc name (fmap show fallback) doc):otherDocs++getArgParserDocs (ArgParserExample str child) =+ do+ childResults <- getArgParserDocs child+ return $ (ExampleDoc str) : childResults++-- We try to look at as little as possible, to avoid the risk of triggering an error.+-- Yay laziness!++getArgParserDocs (ArgParserTest _ _ child ) = getArgParserDocs child+getArgParserDocs (ArgParserFailIf _ _ child ) = getArgParserDocs child++-- To look at this one would almost certainly be death (exception)+getArgParserDocs (ArgParserTerminator _ ) = return []+
+ hacking.md view
@@ -0,0 +1,174 @@++ImplicitCAD Hacking How To+==========================++So you want to improve ImplicitCAD. Yay! More help is a good thing.++As of the time of writing, ImplicitCAD has 3417 lines of code, 896 lines of comments, and 877 blank lines, for a total of 5190 lines spread over 42 files. For a project of ImplicitCAD's scope, that's pretty small, but it's still enough that it can be difficult to find the section we need to change...++The structure of ImplicitCAD is as follows:++```+Graphics+└── Implicit+ ├── Export+ │ ├── Render+ │ └── Symbolic+ ├── ExtOpenScad+ │ └── Util+ └── ObjectUtil+```++`Graphics.Implicit.Export` is, as you may guess, where all the export stuff is. `Graphics.Implicit.ExtOpenScad` is the programming language interpreter for the ExtOpenScad language, our extention of openscad. Finally, the graphics engine is defined in `Graphics.Implicit` and `Graphics.Implicit.ObjectUtil`.++The rest of this file will go through different changes you are likely to want to make and how to implement them.++Language Changes+----------------++Most likely, you want to change one of four things:++* **Expressions**: Expressions are things like `1+2`, `"abc"`, and `[sin(3.14), pi]`. They are defined in `Graphics.Implicit.ExtOpenScad.Expressions`. (Note that `sin` and `pi` are variables, which are defined elsewhere.)++* **Statements**: Statements are things like variable assignment, for loops, and if statements. For example `for (a = [1,2,3]) echo (a);`. Statements are defined in `Graphics.Implicit.ExtOpenScad.Statements`.++```haskell+computationStatement = ...+ ifStatement,+ forStatement,+ ...++...++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+ ...+```+++* **Default Variables**: Like `sin`, `pi`, `sqrt`. These are all defined in ` Graphics.Implicit.ExtOpenScad.Default`. We can just use `toOObj` to convert Haskell values into `OpenscadObj`s and use them as default variable settings. (Small caveat: inputs to `toOObj` can't be polymorphic, so we use a type signature to force it to a certain type.)++```haskell+defaultFunctions = map (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ)))+ [+ ("sin", sin),+ ("cos", cos),+ ("tan", tan),+ ...+ ]+```++* **Default Modules**: Like `sphere` and `linear_extrude`. These are all defined in `Graphics.Implicit.ExtOpenScad.Primitives`.++```haskell+primitives = [ sphere, cube, square, cylinder, ... ]++...++-- **Exmaple of implementing a module**+-- sphere is a module without a suite named sphere,+-- this means that the parser will look for this like+-- sphere(args...);+sphere = moduleWithoutSuite "sphere" $ do+ example "sphere(3);"+ example "sphere(r=5);"+ -- What are the arguments?+ -- The radius, r, which is a (real) number.+ -- Because we don't provide a default, this ends right+ -- here if it doesn't get a suitable argument!+ r :: ℝ <- argument "r"+ `doc` "radius of the sphere"+ -- So what does this module do?+ -- It adds a 3D object, a sphere of radius r,+ -- using the sphere implementation in Prim+ -- (Graphics.Implicit.Primitives)+ addObj3 $ Prim.sphere r++```++Output Formats+--------------++Formats are defined in files like `Graphics.Implicit.Export.TriangleMeshFormats` (as is the case with STLs), `Graphics.Implicit.Export.PolylineMeshFormats` (as is the case with SVGs).++Then, in `Graphics.Implicit.Export`:++```haskell+writeSVG res = writeObject res PolylineFormats.svg+writeSTL res = writeObject res TriangleMeshFormats.stl+```++Rendering Algorithms+--------------------++These are defined in `Graphics.Implicit.Export.Render` and children. `Graphics.Implicit.Export.Render` begins with an outline of how rendering is done:++```haskell+-- Here's the plan for rendering a cube (the 2D case is trivial):++-- (1) We calculate midpoints using interpolate.+-- This guarentees that our mesh will line up everywhere.+-- (Contrast with calculating them in getSegs)++import Graphics.Implicit.Export.Render.Interpolate (interpolate)++...+```++If you are interested on working on this part of the code, read it. The children are also well documented.++Graphics Primitives+-------------------++The most complicated part of ImplicitCAD is the actual graphics engine. Before working on it, please familiarize yourself with the theory as described in [Chris' blog post](http://christopherolah.wordpress.com/2011/11/06/manipulation-of-implicit-functions-with-an-eye-on-cad/) (though changes have occured since then).++The simples way to implement a new primitive is using `implicit`, a contructor that takes an implicit function and boudning box, producing an object. For example, we could have originally defined `sphere` as:++```haskell+sphere :: ℝ -> SymbolicObj3+sphere r = implicit (+ \(x,y,z) -> sqrt (x^2+y^2+z^2) - r,+ ((-r, -r, -r), (r, r, r))+ )+```++and put it in `Graphics.Implicit.Primitives`. However, to allow more powerful optimizations, meta-inspection, and other goodies, frequently used objects should be put in the `SymbolicObj` definitions in `Graphics.Implicit.Definitions`. For example, `sphere`:++```haskell+data SymbolicObj3 =+ Rect3R ℝ ℝ3 ℝ3+ | Sphere ℝ+ ...+```++Then one needs to make the relevant entries in `Graphics.Implicit.ObjectUtil.*`.++`Graphics.Implicit.ObjectUtil.Box3`:++```haskell+getBox3 (Sphere r ) = ((-r, -r, -r), (r,r,r))+```++`Graphics.Implicit.ObjectUtil.GetImplicit3`:++```haskell+getImplicit3 (Sphere r ) =+ \(x,y,z) -> sqrt (x^2 + y^2 + z^2) - r+```++
implicit.cabal view
@@ -1,5 +1,5 @@ name: implicit-version: 0.1.0+version: 0.2.0 cabal-version: >= 1.8 synopsis: Math-inspired programmatic 2&3D CAD: CSG, bevels, and shells; gcode export.. description: A math-inspired programmatic CAD library in haskell.@@ -20,7 +20,6 @@ base >= 3 && < 5, filepath, directory,- download, parsec, unordered-containers, parallel,@@ -30,6 +29,7 @@ text, monads-tf, bytestring,+ bytestring-builder, blaze-builder, blaze-markup, blaze-svg,@@ -40,12 +40,14 @@ snap-core, snap-server, silently,- transformers+ transformers,+ hspec ghc-options: -Wall -- for debugging only.--- -Weverything+ -Wextra+ -Weverything -O2 -optc-O3 -- cannot use, we use infinity in some calculations.@@ -120,8 +122,11 @@ implicit ghc-options: -threaded+ -- see GHC manual 8.2.1 section 6.5.1.+ -feager-blackholing -rtsopts -Wall+ -Weverything -O2 -optc-O3 -optc-ffast-math@@ -160,7 +165,6 @@ -- -fspec-constr-count=10 executable implicitsnap- main-is: implicitsnap.hs hs-source-dirs: programs build-depends:@@ -190,12 +194,12 @@ -threaded -rtsopts -Wall+ -Weverything -O2 -optc-O3 -optc-ffast-math executable Benchmark- main-is: Benchmark.hs hs-source-dirs: programs build-depends:@@ -222,6 +226,7 @@ -threaded -rtsopts -Wall+ -Weverything -O2 -optc-O3 -optc-ffast-math@@ -231,15 +236,22 @@ build-depends: base, mtl, containers, hspec, parsec, implicit main-is: Main.hs hs-source-dirs: tests+ ghc-options:+ -Wall+ -Weverything+ -O2+ -optc-O3 benchmark parser-bench type: exitcode-stdio-1.0- hs-source-dirs: bench- main-is: ParserBench.hs build-depends: base, criterion, random, parsec, implicit+ main-is: ParserBench.hs ghc-options: -Wall- -O2 -optc-O3+ -Weverything+ -O2+ -optc-O3+ -optc-ffast-math source-repository head type: git
programs/Benchmark.hs view
@@ -6,18 +6,23 @@ -- Let's be explicit about where things come from :) +import Prelude (($), (*), (/), String, IO, cos, pi, map, zip3, Maybe(Just, Nothing), Either(Left))+ -- Use criterion for benchmarking. see <http://www.serpentine.com/criterion/>-import Criterion.Main+import Criterion.Main (Benchmark, bgroup, bench, nf, defaultMain) -- The parts of ImplicitCAD we know how to benchmark (in theory).-import Graphics.Implicit (union, circle, writeSVG, writePNG2, writePNG3, writeSTL, SymbolicObj2, SymbolicObj3)+import Graphics.Implicit (union, circle, SymbolicObj2, SymbolicObj3) import Graphics.Implicit.Export.SymbolicObj2 (symbolicGetContour) import Graphics.Implicit.Export.SymbolicObj3 (symbolicGetMesh) import Graphics.Implicit.Primitives (translate, difference, extrudeRM, rect3R) +-- The variable defining distance in our world.+import Graphics.Implicit.Definitions (ℝ)+ -- Haskell representations of objects to benchmark. --- FIXME: move each of these objects into seperate compilable files.+-- FIXME: move each of these objects into seperate compilable files. obj2d_1 :: SymbolicObj2 obj2d_1 =@@ -31,7 +36,9 @@ object1 :: SymbolicObj3 object1 = extrudeRM 0 (Just twist) Nothing Nothing obj2d_1 (Left 40)- where twist h = 35*cos(h*2*pi/60)+ where+ twist :: ℝ -> ℝ+ twist h = 35*cos(h*2*pi/60) object2 :: SymbolicObj3 object2 = squarePipe (10,10,10) 1 100@@ -71,11 +78,14 @@ bench "Get mesh" $ nf (symbolicGetMesh 1) obj ] +benchmarks :: [Benchmark] benchmarks = [ obj3Benchmarks "Object 1" object1 , obj3Benchmarks "Object 2" object2 , obj3Benchmarks "Object 3" object3+ , obj2Benchmarks "Object 2d 1" obj2d_1 ] +main :: IO () main = defaultMain benchmarks
+ programs/ParserBench.hs view
@@ -0,0 +1,61 @@+import Criterion.Main+import Graphics.Implicit.ExtOpenScad.Definitions+import Graphics.Implicit.ExtOpenScad.Parser.Expr+import Graphics.Implicit.ExtOpenScad.Parser.Statement+import Text.ParserCombinators.Parsec hiding (State)+import Text.Printf++lineComment :: Int -> String+lineComment width = "//" ++ ['x' | _ <- [1..width]] ++ "\n"++lineComments :: Int -> String+lineComments n = concat [lineComment 80 | _ <- [1..n]]+ ++ assignments 1 -- to avoid empty file++blockComment :: Int -> Int -> String+blockComment lineCount width =+ "/*" ++ concat [['x' | _ <- [1..width]] ++ "\n" | _ <- [1..lineCount]] ++ "*/"++blockComments :: Int -> Int -> String+blockComments lineCount n = concat [blockComment lineCount 40 | _ <- [1..n]]+ ++ assignments 1 -- to avoid empty file++assignments :: Int -> String+assignments n = concat ["x = (foo + bar);\n" | _ <- [1..n]]++intList :: Int -> String+intList n = "[" ++ concat [show i ++ "," | i <- [1..n]] ++ "0]"++parseExpr :: String -> Expr+parseExpr s = case parse expr0 "src" s of+ Left err -> error (show err)+ Right e -> e++parseStatements :: String -> [StatementI]+parseStatements s = case parseProgram "src" s of+ Left err -> error (show err)+ Right e -> e++deepArithmetic :: Int -> String+deepArithmetic n+ | n == 0 = "1"+ | otherwise = printf "%s + %s * (%s - %s)" d d d d+ where+ d = deepArithmetic (n - 1)++run :: String -> (String -> a) -> String -> Benchmark+run name func input =+ env (return input) $ \s ->+ bench name $ whnf func s++main :: IO ()+main =+ defaultMain+ [ bgroup "comments"+ [ run "line" parseStatements (lineComments 5000)+ , run "block" parseStatements (blockComments 10 500)+ ]+ , run "assignments" parseStatements (assignments 100)+ , run "int list" parseExpr (intList 1000)+ , run "deep arithmetic" parseExpr (deepArithmetic 3)+ ]
programs/extopenscad.hs view
@@ -11,6 +11,8 @@ -- Let's be explicit about what we're getting from where :) +import Prelude (Read(readsPrec), Maybe(Just, Nothing), Either(Left, Right), IO, FilePath, Show, Eq, Ord, String, (++), ($), (*), (/), (==), (>), (**), (-), readFile, minimum, drop, error, map, fst, min, sqrt, tail, take, length, putStrLn, show, print, (>>=), lookup)+ -- Our Extended OpenScad interpreter, and functions to write out files in designated formats. import Graphics.Implicit (runOpenscad, writeSVG, writeBinSTL, writeOBJ, writeSCAD2, writeSCAD3, writeGCodeHacklabLaser, writePNG2, writePNG3) @@ -37,6 +39,10 @@ -- Operator to subtract two points. Used when defining the resolution of a 2d object. import Data.AffineSpace ((.-.)) +import Data.Monoid (Monoid, mappend)++import Control.Applicative ((<$>), (<*>))+ -- NOTE: make sure we don't import (<>) in new versions. import Options.Applicative (fullDesc, progDesc, header, auto, info, helper, help, str, argument, long, short, option, metavar, execParser, Parser, optional, strOption) @@ -84,7 +90,7 @@ -- Lookup an output format for a given output file. Throw an error if one cannot be found. guessOutputFormat :: FilePath -> OutputFormat guessOutputFormat fileName =- maybe (error $ "Unrecognized output format: "<>ext) id+ fromMaybe (error $ "Unrecognized output format: "<>ext) $ readOutputFormat $ tail ext where (_,ext) = splitExtension fileName@@ -130,14 +136,16 @@ instance Read OutputFormat where readsPrec _ myvalue = tryParse formatExtensions- where tryParse [] = [] -- If there is nothing left to try, fail- tryParse ((attempt, result):xs) =- if (take (length attempt) myvalue) == attempt- then [(result, drop (length attempt) myvalue)]- else tryParse xs+ where+ tryParse :: [(String, OutputFormat)] -> [(OutputFormat, String)]+ tryParse [] = [] -- If there is nothing left to try, fail+ tryParse ((attempt, result):xs) =+ if take (length attempt) myvalue == attempt+ then [(result, drop (length attempt) myvalue)]+ else tryParse xs -- Find the resolution to raytrace at.-getRes :: (Map.Map [Char] OVal, [SymbolicObj2], [SymbolicObj3]) -> ℝ+getRes :: (Map.Map String OVal, [SymbolicObj2], [SymbolicObj3]) -> ℝ -- First, use a resolution specified by a variable in the input file. getRes (Map.lookup "$res" -> Just (ONum res), _, _) = res -- Use a resolution chosen for 3D objects.@@ -156,8 +164,8 @@ (p1,p2) = getBox2 obj (x,y) = p2 .-. p1 in case 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)+ ONum qual | qual > 0 -> min (min x y/2) (sqrt(x*y/qual) / 30)+ _ -> min (min x y/2) (sqrt(x*y) / 30) -- fallthrough value. getRes _ = 1 @@ -187,21 +195,21 @@ run :: ExtOpenScadOpts -> IO() run args = do - putStrLn $ "Loading File."+ putStrLn "Loading File." content <- readFile (inputFile args) let format = case () of- _ | Just fmt <- outputFormat args -> Just $ fmt+ _ | Just fmt <- outputFormat args -> Just fmt _ | Just file <- outputFile args -> Just $ guessOutputFormat file _ -> Nothing- putStrLn $ "Processing File."+ putStrLn "Processing File." case runOpenscad content of- Left err -> putStrLn $ show $ err+ Left err -> print err Right openscadProgram -> do s@(_, obj2s, obj3s) <- openscadProgram- let res = maybe (getRes s) id (resolution args)+ let res = fromMaybe (getRes s) (resolution args) let basename = fst (splitExtension $ inputFile args) let posDefExt = case format of Just f -> Prelude.lookup f (map swap formatExtensions)@@ -214,7 +222,7 @@ putStrLn $ "Rendering 3D object to " ++ output putStrLn $ "With resolution " ++ show res putStrLn $ "In box " ++ show (getBox3 obj)- putStrLn $ show obj+ print obj export3 format res output obj ([obj], []) -> do let output = fromMaybe@@ -223,7 +231,7 @@ putStrLn $ "Rendering 2D object to " ++ output putStrLn $ "With resolution " ++ show res putStrLn $ "In box " ++ show (getBox2 obj)- putStrLn $ show obj+ print obj export2 format res output obj ([], []) -> putStrLn "No objects to render." _ -> putStrLn "Multiple/No objects, what do you want to render?"
programs/implicitsnap.hs view
@@ -5,15 +5,19 @@ -- Allow us to use explicit foralls when writing function type declarations. {-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE OverloadedStrings, ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-}+ -- A Snap(HTTP) server providing an ImplicitCAD REST API. -- Let's be explicit about what we're getting from where :) +import Prelude (IO, Maybe(Just, Nothing), Ord, String, Bool(True, False), Either(Left, Right), Show, Char, ($), (++), (>), (.), (-), (/), (*), (**), sqrt, min, max, minimum, maximum, show, return)+ import Control.Applicative ((<|>)) -import Snap.Core (Snap, route, writeBS, method, Method(GET), modifyResponse, setContentType, getRequest, rqParam)+import Snap.Core (Snap, route, writeBS, method, Method(GET), modifyResponse, setContentType, setTimeout, getRequest, rqParam) import Snap.Http.Server (quickHttpServe) import Snap.Util.GZip (withCompression) @@ -25,11 +29,18 @@ -- Functions for finding a box around an object, so we can define the area we need to raytrace inside of. import Graphics.Implicit.ObjectUtil (getBox2, getBox3) +-- Definitions of the datatypes used for 2D objects, 3D objects, and for defining the resolution to raytrace at. import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3, ℝ) +-- Use default values when a Maybe is Nothing.+import Data.Maybe (fromMaybe)+ import Graphics.Implicit.Export.TriangleMeshFormats (jsTHREE, stl) import Graphics.Implicit.Export.PolylineFormats (svg, hacklabLaserGCode) +-- Operator to subtract two points. Used when defining the resolution of a 2d object.+import Data.AffineSpace ((.-.))+ -- class DiscreteApprox import Graphics.Implicit.Export.DiscreteAproxable (discreteAprox) @@ -57,21 +68,49 @@ renderHandler :: Snap () renderHandler = method GET $ withCompression $ do modifyResponse $ setContentType "application/x-javascript"+ setTimeout 600 request <- getRequest case (rqParam "source" request, rqParam "callback" request, rqParam "format" request) of- (Just [source], Just [callback], Nothing) -> do- writeBS $ BS.Char.pack $ executeAndExport+ (Just [source], Just [callback], Nothing) ->+ writeBS . BS.Char.pack $ executeAndExport (BS.Char.unpack source) (BS.Char.unpack callback) Nothing- (Just [source], Just [callback], Just [format]) -> do- writeBS $ BS.Char.pack $ executeAndExport+ (Just [source], Just [callback], Just [format]) ->+ writeBS . BS.Char.pack $ executeAndExport (BS.Char.unpack source) (BS.Char.unpack callback) (Just $ BS.Char.unpack format) (_, _, _) -> writeBS "must provide source and callback as 1 GET variable each" +-- Find the resolution to raytrace at. getRes :: forall k. (Data.String.IsString k, Ord k) => (Map k OVal, [SymbolicObj2], [SymbolicObj3]) -> ℝ++-- First, use a resolution specified by a variable in the input file.+getRes (Map.lookup "$res" -> Just (ONum res), _, _) = res++-- If there was no resolution specified, use a resolution chosen for 3D objects.+-- FIXME: magic numbers.+getRes (varlookup, _, obj:_) =+ let+ ((x1,y1,z1),(x2,y2,z2)) = getBox3 obj+ (x,y,z) = (x2-x1, y2-y1, z2-z1)+ in case 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)+-- Use a resolution chosen for 2D objects.+-- FIXME: magic numbers.+getRes (varlookup, obj:_, _) =+ let+ (p1,p2) = getBox2 obj+ (x,y) = p2 .-. p1+ in case fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of+ ONum qual | qual > 0 -> min (min x y/2) (sqrt(x*y/qual) / 30)+ _ -> min (min x y/2) (sqrt(x*y ) / 30)+-- fallthrough value.+getRes _ = 1++{- getRes (varlookup, obj2s, obj3s) = let qual = case Map.lookup "$quality" varlookup of@@ -83,8 +122,8 @@ where ((x1,y1,z1),(x2,y2,z2)) = getBox3 obj (x,y,z) = (x2-x1, y2-y1, z2-z1)- (obj:_, _) -> ( min (min x y/2) ((x*y )**0.5 / 30)- , min (min x y/2) ((x*y/qual)**0.5 / 30) )+ (obj:_, _) -> ( min (min x y/2) (sqrt(x*y ) / 30)+ , min (min x y/2) (sqrt(x*y/qual) / 30) ) where ((x1,y1),(x2,y2)) = getBox2 obj (x,y) = (x2-x1, y2-y1)@@ -98,7 +137,7 @@ if qual <= 30 then qualRes else -1-+-} getWidth :: forall t. (t, [SymbolicObj2], [SymbolicObj3]) -> ℝ getWidth (_, _, obj:_) = maximum [x2-x1, y2-y1, z2-z1]@@ -112,6 +151,7 @@ executeAndExport :: String -> String -> Maybe String -> String executeAndExport content callback maybeFormat = let+ showB :: IsString t => Bool -> t showB True = "true" showB False = "false" callbackF :: Bool -> Bool -> ℝ -> String -> String@@ -119,6 +159,7 @@ callback ++ "([null," ++ show msg ++ "," ++ showB is2D ++ "," ++ show w ++ "]);" callbackF True is2D w msg = callback ++ "([new Shape()," ++ show msg ++ "," ++ showB is2D ++ "," ++ show w ++ "]);"+ callbackS :: (Show a1, Show a) => a -> a1 -> [Char] callbackS str msg = callback ++ "([" ++ show str ++ "," ++ show msg ++ ",null,null]);" in case runOpenscad content of Left err ->@@ -130,7 +171,7 @@ msgs = showErrorMessages' $ errorMessages err in callbackF False False 1 $ (\s-> "error (" ++ show line ++ "):" ++ s) msgs Right openscadProgram -> unsafePerformIO $ do- (msgs,s) <- capture $ openscadProgram+ (msgs,s) <- capture openscadProgram let res = getRes s w = getWidth s@@ -162,6 +203,7 @@ callbackS (TL.unpack (svg (discreteAprox res obj))) msgs (Right (Just obj, _), Just "gcode/hacklab-laser") -> callbackS (TL.unpack (hacklabLaserGCode (discreteAprox res obj))) msgs-+ (Right (_ , _), _) ->+ callbackF False False 1 "unexpected case"
+ stack.yaml view
@@ -0,0 +1,29 @@+# For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md++# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)+resolver: lts-9.8++# Local packages, usually specified by relative directory name+packages:+- '.'++# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)+extra-deps: []++# Override default flag values for local packages and extra-deps+flags: {}++# Control whether we use the GHC we find on the path+# system-ghc: true++# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: >= 0.1.4.0++# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64++# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]
tests/Main.hs view
@@ -1,8 +1,22 @@-import Test.Hspec-import ParserSpec.Statement-import ParserSpec.Expr+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Copyright (C) 2018, Julia Longtin (julial@turinglace.com)+-- Released under the GNU AGPLV3+, see LICENSE +-- be explicit about what we import.+import Prelude (($), IO)++-- our testing engine.+import Test.Hspec(hspec, describe)++-- the test forstatements.+import ParserSpec.Statement(statementSpec)++-- the test for expressions.+import ParserSpec.Expr(exprSpec)+ main :: IO () main = hspec $ do- describe "expressions" $ exprSpec- describe "statements" $ statementSpec+ -- run tests against the expression engine.+ describe "expressions" exprSpec+ -- and now, against the statement engine.+ describe "statements" statementSpec
+ tests/NOTES view
@@ -0,0 +1,2 @@++https://github.com/nmz787/microfluidic-cad: GPLV2 or greater
+ tests/ParserSpec/Expr.hs view
@@ -0,0 +1,129 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Copyright (C) 2014-2017, Julia Longtin (julial@turinglace.com)+-- Released under the GNU AGPLV3+, see LICENSE++module ParserSpec.Expr (exprSpec) where++-- Be explicit about what we import.+import Prelude (String, Bool(True, False), ($), (<*), )++-- Hspec, for writing specs.+import Test.Hspec (describe, Expectation, Spec, it, shouldBe, pendingWith, specify)++-- parsed expression components.+import Graphics.Implicit.ExtOpenScad.Definitions (Expr(Var, ListE, (:$)) )++-- the expression parser entry point.+import Graphics.Implicit.ExtOpenScad.Parser.Expr (expr0)++import ParserSpec.Util (fapp, num, bool, plus, minus, mult, modulo, power, divide, negate, and, or, gt, lt, ternary, append, index, parseWithLeftOver)++import Data.Either (Either(Right))++import Text.ParserCombinators.Parsec (parse, eof)++-- An operator for expressions for "the left side should parse to the right side."+infixr 1 -->+(-->) :: String -> Expr -> Expectation+(-->) source expr =+ parse (expr0 <* eof) "<expr>" source `shouldBe` Right expr++-- An operator for expressions for "the left side should parse to the right side, and some should be left over.+infixr 1 -->++(-->+) :: String -> (Expr, String) -> Expectation+(-->+) source (result, leftover) =+ parseWithLeftOver expr0 source `shouldBe` Right (result, leftover)++ternaryIssue :: Expectation -> Expectation+ternaryIssue _ = pendingWith "parser doesn't handle ternary operator correctly"++negationIssue :: Expectation -> Expectation+negationIssue _ = pendingWith "parser doesn't handle negation operator correctly"++logicalSpec :: Spec+logicalSpec = do+ describe "not" $ do+ specify "single" $ "!foo" --> negate [Var "foo"]+ specify "multiple" $+ negationIssue $ "!!!foo" --> negate [negate [negate [Var "foo"]]]+ it "handles and/or" $ do+ "foo && bar" --> and [Var "foo", Var "bar"]+ "foo || bar" --> or [Var "foo", Var "bar"]+ describe "ternary operator" $ do+ specify "with primitive expressions" $+ "x ? 2 : 3" --> ternary [Var "x", num 2, num 3]+ specify "with parenthesized comparison" $+ "(1 > 0) ? 5 : -5" --> ternary [gt [num 1, num 0], num 5, num (-5)]+ specify "with comparison in head position" $+ ternaryIssue $ "1 > 0 ? 5 : -5" --> ternary [gt [num 1, num 0], num 5, num (-5)]+ specify "with comparison in head position, and addition in tail" $+ ternaryIssue $ "1 > 0 ? 5 : 1 + 2" -->+ ternary [gt [num 1, num 0], num 5, plus [num 1, num 2]]++literalSpec :: Spec+literalSpec = do+ it "handles integers" $+ "12356" --> num 12356+ it "handles floats" $+ "23.42" --> num 23.42+ describe "booleans" $ do+ it "accepts true" $ "true" --> bool True+ it "accepts false" $ "false" --> bool False++exprSpec :: Spec+exprSpec = do+ describe "literals" literalSpec+ describe "identifiers" $+ it "accepts valid variable names" $ do+ "foo" --> Var "foo"+ "foo_bar" --> Var "foo_bar"+ describe "grouping" $ do+ it "allows parens" $+ "( false )" --> bool False+ it "handles vectors" $+ "[ 1, 2, 3 ]" --> ListE [num 1, num 2, num 3]+ it "handles lists" $+ "( 1, 2, 3 )" --> ListE [num 1, num 2, num 3]+ it "handles generators" $+ "[ a : 1 : b + 10 ]" -->+ fapp "list_gen" [Var "a", num 1, plus [Var "b", num 10]]+ it "handles indexing" $+ "foo[23]" --> index [Var "foo", num 23]+ describe "arithmetic" $ do+ it "handles unary +/-" $ do+ "-42" --> num (-42)+ "+42" --> num 42+ it "handles +" $ do+ "1 + 2" --> plus [num 1, num 2]+ "1 + 2 + 3" --> plus [num 1, num 2, num 3]+ it "handles -" $ do+ "1 - 2" --> minus [num 1, num 2]+ "1 - 2 - 3" --> minus [minus [num 1, num 2], num 3]+ it "handles +/- in combination" $ do+ "1 + 2 - 3" --> plus [num 1, minus [num 2, num 3]]+ "2 - 3 + 4" --> plus [minus [num 2, num 3], num 4]+ "1 + 2 - 3 + 4" --> plus [num 1, minus [num 2, num 3], num 4]+ "1 + 2 - 3 + 4 - 5 - 6" --> plus [num 1,+ minus [num 2, num 3],+ minus [minus [num 4, num 5],+ num 6]]+ it "handles exponentiation" $+ "x ^ y" --> power [Var "x", Var "y"]+ it "handles *" $ do+ "3 * 4" --> mult [num 3, num 4]+ "3 * 4 * 5" --> mult [num 3, num 4, num 5]+ it "handles /" $+ "4.2 / 2.3" --> divide [num 4.2, num 2.3]+ it "handles precedence" $+ "1 + 2 / 3 * 5" --> plus [num 1, mult [divide [num 2, num 3], num 5]]+ it "handles append" $+ "foo ++ bar ++ baz" --> append [Var "foo", Var "bar", Var "baz"]+ describe "logical operators" logicalSpec+ describe "application" $ do+ specify "base case" $ "foo(x)" --> Var "foo" :$ [Var "x"]+ specify "multiple arguments" $+ "foo(x, 1, 2)" --> Var "foo" :$ [Var "x", num 1, num 2]+ specify "multiple" $+ "foo(x, 1, 2)(5)(y)" --> ((Var "foo" :$ [Var "x", num 1, num 2]) :$ [num 5]) :$ [Var "y"]+ specify "multiple, with indexing" $+ "foo(x)[0](y)" --> ((index [(Var "foo" :$ [Var "x"]), num 0]) :$ [Var "y"])
+ tests/ParserSpec/Statement.hs view
@@ -0,0 +1,93 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Copyright (C) 2014-2017, Julia Longtin (julial@turinglace.com)+-- Released under the GNU AGPLV3+, see LICENSE++-- statement related hspec tests.+module ParserSpec.Statement (statementSpec) where++import Prelude (String, Maybe(Just), Bool(True), ($))++import Test.Hspec (Spec, Expectation, shouldBe, shouldSatisfy, it, pendingWith, describe)++-- import Text.ParserCombinators.Parsec ()++import ParserSpec.Util (bool, num, minus, mult, index)++import Graphics.Implicit.ExtOpenScad.Definitions (StatementI(StatementI), Symbol, Expr(ListE, LamE, Var), Statement(NewModule, ModuleCall, If, (:=)), Pattern(Name, ListP))++-- Parse an ExtOpenScad program.+import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram)++import Data.Either (Either(Right), isLeft)++-- an expectation that a string become a statement.+infixr 1 -->+(-->) :: String -> [StatementI] -> Expectation+(-->) source stmts =+ parseProgram source `shouldBe` Right stmts++-- an expectation that a string generates an error.+parsesAsError :: String -> Expectation+parsesAsError source = parseProgram source `shouldSatisfy` isLeft++single :: Statement StatementI -> [StatementI]+single st = [StatementI 1 st]++call :: Symbol -> [(Maybe Symbol, Expr)] -> [StatementI] -> StatementI+call name args stmts = StatementI 1 (ModuleCall name args stmts)++-- test a simple if block.+ifSpec :: Spec+ifSpec = it "parses" $+ "if (true) { a(); } else { b(); }" --> + single ( If (bool True) [call "a" [] []] [call "b" [] []])++-- test assignments.+assignmentSpec :: Spec+assignmentSpec = do+ it "parses correctly" $+ "y = -5;" --> single ( Name "y" := num (-5))+ it "handles pattern matching" $+ "[x, y] = [1, 2];" --> single (ListP [Name "x", Name "y"] := ListE [num 1, num 2])+ it "handles the function keyword and definitions" $+ "function foo(x, y) = x * y;" --> single fooFunction+ it "nested indexing" $+ "x = [y[0] - z * 2];" -->+ single ( Name "x" := ListE [minus [index [Var "y", num 0],+ mult [Var "z", num 2]]])+ where+ fooFunction :: Statement st+ fooFunction = Name "foo" := LamE [Name "x", Name "y"]+ (mult [Var "x", Var "y"])++emptyFileIssue :: Expectation -> Expectation+emptyFileIssue _ = pendingWith "parser should probably allow empty files"+++statementSpec :: Spec+statementSpec = do+ describe "assignment" $ assignmentSpec+ describe "if" $ ifSpec+ describe "empty file" $+ it "returns an empty list" $+ emptyFileIssue $ "" --> []+ describe "line comment" $ + it "parses as empty" $ emptyFileIssue $ "// foish bar\n" --> []+ describe "module call" $ + it "parses" $ "foo();" --> single (ModuleCall "foo" [] [])+ describe "difference of two cylinders" $+ it "parses correctly" $+ "difference(){ cylinder(r=5,h=20); cylinder(r=2,h=20); }"+ --> single (+ ModuleCall "difference" [] [+ call "cylinder" [(Just "r", num 5.0),+ (Just "h", num 20.0)]+ [],+ call "cylinder" [(Just "r", num 2.0),+ (Just "h", num 20.0)]+ []])+ describe "empty module definition" $+ it "parses correctly" $+ "module foo_bar() {}" --> single (NewModule "foo_bar" [] [])++
+ tests/ParserSpec/Util.hs view
@@ -0,0 +1,79 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)+-- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com)+-- Released under the GNU AGPLV3+, see LICENSE++-- Allow us to use explicit foralls when writing function type declarations.+{-# LANGUAGE ExplicitForAll #-}++-- Utilities+module ParserSpec.Util+ ( num+ , bool+ , fapp+ , plus+ , minus+ , mult+ , modulo+ , power+ , divide+ , negate+ , and+ , or+ , gt+ , lt+ , ternary+ , append+ , index+ , parseWithLeftOver+ ) where++-- be explicit about where we get things from.+import Prelude (Bool, String, Either, (<), ($), (.), otherwise)++-- The datatype of positions in our world.+import Graphics.Implicit.Definitions (ℝ)++-- The datatype of expressions, symbols, and values in the OpenScad language.+import Graphics.Implicit.ExtOpenScad.Definitions (Expr(LitE, (:$), Var, ListE), OVal(ONum, OBool))++import Text.ParserCombinators.Parsec (Parser, ParseError, parse, manyTill, anyChar, eof)++import Control.Applicative ((<$>), (<*>))++num :: ℝ -> Expr+num x+ -- FIXME: the parser should handle negative number literals+ -- directly, we abstract that deficiency away here+ | x < 0 = oapp "negate" [LitE $ ONum (-x)]+ | otherwise = LitE $ ONum x++bool :: Bool -> Expr+bool = LitE . OBool++plus,minus,mult,modulo,power,divide,negate,and,or,gt,lt,ternary,append,index :: [Expr] -> Expr+minus = oapp "-"+modulo = oapp "%"+power = oapp "^"+divide = oapp "/"+and = oapp "&&"+or = oapp "||"+gt = oapp ">"+lt = oapp "<"+ternary = oapp "?"+negate = oapp "!"+index = oapp "index"+plus = fapp "+"+mult = fapp "*"+append = fapp "++"++-- we need two different kinds of application functions+oapp,fapp :: String -> [Expr] -> Expr+oapp name args = Var name :$ args+fapp name args = Var name :$ [ListE args]++parseWithLeftOver :: Parser a -> String -> Either ParseError (a, String)+parseWithLeftOver p = parse ((,) <$> p <*> leftOver) ""+ where+ leftOver :: Parser String+ leftOver = manyTill anyChar eof
+ tests/tobacco_mesophyll_protoplast_fusion_device.escad view
@@ -0,0 +1,493 @@+// tobacco_mesophyll_protoplast_fusion_device.escad+//++$quality = 1;++module pdms_slab(distance_output_port_from_center)+{+ width=distance_output_port_from_center*3;+ translate ([width/-2,width/-2]) square(size=[width, width]);+}+++module single_output_port(radius_from_center, output_port_diameter, angle)+{+ translate ([(radius_from_center)*cos(angle), (radius_from_center)*sin(angle)]) circle(output_port_diameter/2);+}+++module radial_outlets(input_port_diameter,+ len_funnel,+ length_catcher,+ output_port_diameter,+ num_output_ports)+{+ radius_from_center=(input_port_diameter/2) + len_funnel + length_catcher;+ union() {+ ++ for( angle= [ 1: 1: num_output_ports] ) + {+ single_output_port(radius_from_center, output_port_diameter, (2*pi)/num_output_ports*angle);+ }+ }+}+++module single_radial_protoplast_catcher(input_port_radius,+ angle,+ angle_degrees,+ length_catcher,+ width_catcher,+ catcher_post_w,+ catcher_post_h,+ catcher_post_roundness,+ catcher_post_pitch,+ len_funnel)+{+ y_neg = width_catcher/-2;+ x_neg = length_catcher/-2;+ y_pos = width_catcher/2;+ x_pos = length_catcher/2;+ //translate([(radius+y_pos/2)*cos(angle), (radius+y_pos/2)*sin(angle)]){+ translate([(input_port_radius+len_funnel)*cos(angle), (input_port_radius+len_funnel)*sin(angle)])+ {+ rotate(angle_degrees)+ {+ translate([0, y_neg])+ {+ difference()+ {+ square(size=[length_catcher, width_catcher]);+ union()+ {+ for (i=[0:1:(width_catcher/catcher_post_pitch)+1])+ {+ translate([length_catcher*3/4, (i*catcher_post_pitch)+(catcher_post_pitch)]) square([catcher_post_h,+ catcher_post_w],+ r=catcher_post_roundness);+ translate([length_catcher*3/4 + catcher_post_pitch + (catcher_post_h/2), (i*catcher_post_pitch)+(catcher_post_pitch)]) square([catcher_post_h,+ catcher_post_w],+ r=catcher_post_roundness);+ }+ }+ }+ }+ }+ }+}++//posts.escad START++module bifurcated_posts(num_posts_across_min,+ half_offset,+ symmetric_bifurcation_post_w,+ symmetric_bifurcation_post_h,+ symmetric_bifurcation_post_roundness,+ symmetric_bifurcation_post_pitch,+ num_rows)+{+ even_odd=0;+ union()+ {+ for (r=[0:1:num_rows])+ //for (r=[0:1:1])+ {+ row_num_posts=(num_posts_across_min+r*2);+ even_odd_row_offset = 0;+ if (even_odd==1){+ even_odd=0;+ even_odd_row_offset = (symmetric_bifurcation_post_pitch/2);++ }+ else {+ even_odd=1;+ row_num_posts=row_num_posts+1;+ }+ //For Pattern Expr [st]+ for (i=[0:1:row_num_posts])+ { + + //translate([r*symmetric_bifurcation_post_pitch,+ // (i*symmetric_bifurcation_post_pitch)-(r*symmetric_bifurcation_post_pitch)+even_odd_row_offset-half_inner_width-symmetric_bifurcation_post_pitch+(symmetric_bifurcation_post_w*1.5)])+ translate([r*symmetric_bifurcation_post_pitch,+ (half_offset ++ (i*symmetric_bifurcation_post_pitch)-+ (r*symmetric_bifurcation_post_pitch)-+ (symmetric_bifurcation_post_w/2)++ (even_odd_row_offset)+ )+ ])+ {+ square([symmetric_bifurcation_post_h,+ symmetric_bifurcation_post_w],+ r=symmetric_bifurcation_post_roundness);+ }+ }+ }+ }+}++module single_symmetrical_bifurcation_funnel(input_symmetric_bifurcation_inner_width,+ input_symmetric_bifurcation_outer_width,+ symmetric_bifurcation_post_w,+ symmetric_bifurcation_post_h,+ symmetric_bifurcation_post_roundness,+ symmetric_bifurcation_post_pitch,+ num_posts_across_min,+ num_rows,+ len_funnel)+{+ x_neg = len_funnel/-2;++ y_neg = input_symmetric_bifurcation_outer_width/-2;++ half_offset=((input_symmetric_bifurcation_outer_width-input_symmetric_bifurcation_inner_width)/2);+ + translate([0, y_neg]){ + difference()+ //union()+ {+ + polygon([[0,half_offset],+ [0, half_offset + input_symmetric_bifurcation_inner_width],+ [len_funnel, input_symmetric_bifurcation_outer_width],+ [len_funnel, 0]+ ]);+ + //square(input_symmetric_bifurcation_inner_width);+ bifurcated_posts(num_posts_across_min,+ half_offset,+ symmetric_bifurcation_post_w,+ symmetric_bifurcation_post_h,+ symmetric_bifurcation_post_roundness,+ symmetric_bifurcation_post_pitch,+ num_rows);+ + }+ }+}++// posts.escad DONE++module single_radial_symmetrical_bifurcation_funnel(radius_from_center,+ angle_rad,+ angle_deg,+ input_symmetric_bifurcation_inner_width,+ input_symmetric_bifurcation_outer_width,+ symmetric_bifurcation_post_w,+ symmetric_bifurcation_post_h,+ symmetric_bifurcation_post_roundness,+ symmetric_bifurcation_post_pitch,+ num_posts_across_min,+ num_rows,+ len_funnel)+{+ tangent_chord_offset=(radius_from_center- (radius_from_center*cos(asin(input_symmetric_bifurcation_inner_width/radius_from_center))))/4;+ translate([(radius_from_center)*cos(angle_rad), (radius_from_center)*sin(angle_rad)])+ {+ rotate(angle_deg)+ {+ single_symmetrical_bifurcation_funnel(input_symmetric_bifurcation_inner_width,+ input_symmetric_bifurcation_outer_width,+ symmetric_bifurcation_post_w,+ symmetric_bifurcation_post_h,+ symmetric_bifurcation_post_roundness,+ symmetric_bifurcation_post_pitch,+ num_posts_across_min,+ num_rows,+ len_funnel);+ }+ }+}+++module radial_center_input(input_port_diameter,+ num_output_ports,+ output_connection_width+ )+{+ radius_from_center = input_port_diameter/2;+ half_inner_width = output_connection_width/2;+ tangent_chord_offset = radius_from_center - (radius_from_center*cos(asin(output_connection_width/radius_from_center)));+ difference()+ {+ circle(r=input_port_diameter/2);+ union()+ {+ for( angle = [ 1: 1: num_output_ports] )+ {+ angle_rad = (2*pi)/num_output_ports*angle;+ angle_deg = (360.0/num_output_ports*angle);+ translate([(radius_from_center)*cos(angle_rad), (radius_from_center)*sin(angle_rad)])+ {+ rotate(angle_deg)+ {+ translate([tangent_chord_offset/-4,-half_inner_width])+ {+ square(output_connection_width);+ }+ }+ }+ }+ }+ }+}+++module radial_columns(symmetric_bifurcation_start_radius,+ input_symmetric_bifurcation_inner_width,+ input_symmetric_bifurcation_outer_width,+ symmetric_bifurcation_post_w,+ symmetric_bifurcation_post_h,+ symmetric_bifurcation_post_roundness,+ symmetric_bifurcation_post_pitch,+ length_catcher,+ width_catcher,+ catcher_post_w,+ catcher_post_h,+ catcher_post_roundness,+ catcher_post_pitch,+ num_output_ports,+ num_posts_across_min,+ num_rows,+ len_funnel)+{+ union(){+ for( angle = [ 1: 1: num_output_ports] ) + {+ angle_rad = (2*pi)/num_output_ports*angle;+ angle_deg = ((2)/num_output_ports*angle)*(180);+ tangent_chord_offset=(symmetric_bifurcation_start_radius- (symmetric_bifurcation_start_radius*cos(asin(input_symmetric_bifurcation_inner_width/symmetric_bifurcation_start_radius))))/4;+ translate([(-tangent_chord_offset)*cos(angle_rad), (-tangent_chord_offset)*sin(angle_rad)])+ {+ single_radial_symmetrical_bifurcation_funnel(symmetric_bifurcation_start_radius,+ angle_rad,+ angle_deg,+ input_symmetric_bifurcation_inner_width,+ input_symmetric_bifurcation_outer_width,+ symmetric_bifurcation_post_w,+ symmetric_bifurcation_post_h,+ symmetric_bifurcation_post_roundness,+ symmetric_bifurcation_post_pitch,+ num_posts_across_min,+ num_rows,+ len_funnel);+ + single_radial_protoplast_catcher(input_port_radius=symmetric_bifurcation_start_radius, + angle=angle_rad,+ angle_degrees=angle_deg,+ length_catcher,+ width_catcher,+ catcher_post_w,+ catcher_post_h,+ catcher_post_roundness,+ catcher_post_pitch,+ len_funnel);+ + }+ }+ }+}+++module protoplast_bottom_layer_2d(input_port_diameter,+ input_symmetric_bifurcation_inner_width,+ input_symmetric_bifurcation_outer_width,+ symmetric_bifurcation_post_w,+ symmetric_bifurcation_post_h,+ symmetric_bifurcation_post_roundness,+ symmetric_bifurcation_post_pitch,+ length_catcher,+ width_catcher,+ catcher_post_w,+ catcher_post_h,+ catcher_post_roundness,+ catcher_post_pitch,+ distance_output_port_from_center,+ dist_center_catcher_to_center_device,+ io_height,+ protoplast_chamber_height,+ output_port_diameter,+ num_output_ports)+{+ union() + {+ radial_center_input(input_port_diameter,+ num_output_ports,+ input_symmetric_bifurcation_inner_width);+ + num_posts_across_min = input_symmetric_bifurcation_inner_width / symmetric_bifurcation_post_pitch;+ num_posts_across_max = input_symmetric_bifurcation_outer_width / symmetric_bifurcation_post_pitch;+ + num_rows=(num_posts_across_max - num_posts_across_min)/2;+ len_funnel = num_rows*symmetric_bifurcation_post_pitch;++ radial_columns(input_port_diameter/2,+ input_symmetric_bifurcation_inner_width,+ input_symmetric_bifurcation_outer_width,+ symmetric_bifurcation_post_w,+ symmetric_bifurcation_post_h,+ symmetric_bifurcation_post_roundness,+ symmetric_bifurcation_post_pitch,+ length_catcher,+ width_catcher,+ catcher_post_w,+ catcher_post_h,+ catcher_post_roundness,+ catcher_post_pitch,+ num_output_ports,+ num_posts_across_min,+ num_rows,+ len_funnel);+ + radial_outlets(input_port_diameter,+ len_funnel,+ length_catcher,+ output_port_diameter,+ num_output_ports,+ 0.5,+ 0.1);+ }+}+++module protoplast_io(input_port_diameter,+ input_symmetric_bifurcation_inner_width,+ input_symmetric_bifurcation_outer_width,+ symmetric_bifurcation_post_w,+ symmetric_bifurcation_post_h,+ symmetric_bifurcation_post_roundness,+ symmetric_bifurcation_post_pitch,+ length_catcher,+ width_catcher,+ catcher_post_w,+ catcher_post_h,+ catcher_post_roundness,+ catcher_post_pitch,+ distance_output_port_from_center,+ dist_center_catcher_to_center_device,+ io_height,+ protoplast_chamber_height,+ output_port_diameter,+ num_output_ports)+{+ union()+ { + radial_center_input(input_port_diameter,+ num_output_ports,+ input_symmetric_bifurcation_inner_width);+ + num_posts_across_min = input_symmetric_bifurcation_inner_width / symmetric_bifurcation_post_pitch;+ num_posts_across_max = input_symmetric_bifurcation_outer_width / symmetric_bifurcation_post_pitch;+ + num_rows=(num_posts_across_max - num_posts_across_min)/2;+ len_funnel = num_rows*symmetric_bifurcation_post_pitch;++ radial_outlets(input_port_diameter,+ len_funnel,+ length_catcher,+ output_port_diameter,+ num_output_ports,+ 0.5,+ 0.1);+ }+}+++module tobacco_mesophyll_protoplast_fusion_device(input_port_diameter,+ input_symmetric_bifurcation_inner_width,+ input_symmetric_bifurcation_outer_width,+ symmetric_bifurcation_post_w,+ symmetric_bifurcation_post_h,+ symmetric_bifurcation_post_roundness,+ symmetric_bifurcation_post_pitch,+ length_catcher,+ width_catcher,+ catcher_post_w,+ catcher_post_h,+ catcher_post_roundness,+ catcher_post_pitch,+ distance_output_port_from_center,+ dist_center_catcher_to_center_device,+ io_height,+ protoplast_chamber_height,+ output_port_diameter,+ num_output_ports)+{+ difference()+ {+ linear_extrude(io_height)+ {+ pdms_slab(distance_output_port_from_center);+ }+ union()+ {+ linear_extrude(protoplast_chamber_height)+ protoplast_bottom_layer_2d(input_port_diameter,+ input_symmetric_bifurcation_inner_width,+ input_symmetric_bifurcation_outer_width,+ symmetric_bifurcation_post_w,+ symmetric_bifurcation_post_h,+ symmetric_bifurcation_post_roundness,+ symmetric_bifurcation_post_pitch,+ length_catcher,+ width_catcher,+ catcher_post_w,+ catcher_post_h,+ catcher_post_roundness,+ catcher_post_pitch,+ distance_output_port_from_center,+ dist_center_catcher_to_center_device,+ io_height,+ protoplast_chamber_height,+ output_port_diameter,+ num_output_ports);+ linear_extrude(io_height)+ protoplast_io(input_port_diameter,+ input_symmetric_bifurcation_inner_width,+ input_symmetric_bifurcation_outer_width,+ symmetric_bifurcation_post_w,+ symmetric_bifurcation_post_h,+ symmetric_bifurcation_post_roundness,+ symmetric_bifurcation_post_pitch,+ length_catcher,+ width_catcher,+ catcher_post_w,+ catcher_post_h,+ catcher_post_roundness,+ catcher_post_pitch,+ distance_output_port_from_center,+ dist_center_catcher_to_center_device,+ io_height,+ protoplast_chamber_height,+ output_port_diameter,+ num_output_ports);+ }+ }+}+++tobacco_mesophyll_protoplast_fusion_device(input_port_diameter=1200,+ input_symmetric_bifurcation_inner_width=200,+ input_symmetric_bifurcation_outer_width=900,+ symmetric_bifurcation_post_w=20,+ symmetric_bifurcation_post_h=30,+ symmetric_bifurcation_post_roundness=15,+ symmetric_bifurcation_post_pitch=40,+ length_catcher=3200,+ width_catcher=900,+ catcher_post_w=20,+ catcher_post_h=30,+ catcher_post_roundness=20,+ catcher_post_pitch=20+(20/2),+ distance_output_port_from_center=3200+200+800,+ dist_center_catcher_to_center_device = (3200/2)+800,+ + io_height=500,+ protoplast_chamber_height=55,+ output_port_diameter=1200,+ + num_output_ports=5+ );+