implicit 0.2.0 → 0.3.0.0
raw patch · 88 files changed
+4668/−4691 lines, 88 filesdep −NumInstancesdep −bytestring-builderdep −mtldep ~basenew-component:exe:docgen
Dependencies removed: NumInstances, bytestring-builder, mtl, random, silently, unordered-containers
Dependency ranges changed: base
Files
- .gitignore +0/−9
- CONTRIBUTORS +0/−28
- Examples/example1.scad +0/−4
- Examples/example10.escad +0/−2
- Examples/example11.hs +0/−9
- Examples/example12.hs +0/−8
- Examples/example13.hs +0/−8
- Examples/example2.escad +0/−5
- Examples/example3.escad +0/−10
- Examples/example4.escad +0/−10
- Examples/example5.escad +0/−10
- Examples/example6.escad +0/−10
- Examples/example7.escad +0/−10
- Examples/example8.escad +0/−7
- Examples/example9.escad +0/−4
- Graphics/Implicit.hs +25/−51
- Graphics/Implicit/Definitions.hs +105/−64
- Graphics/Implicit/Export.hs +22/−21
- Graphics/Implicit/Export/DiscreteAproxable.hs +52/−33
- Graphics/Implicit/Export/MarchingSquares.hs +0/−218
- Graphics/Implicit/Export/MarchingSquaresFill.hs +69/−81
- Graphics/Implicit/Export/NormedTriangleMeshFormats.hs +22/−19
- Graphics/Implicit/Export/PolylineFormats.hs +122/−55
- Graphics/Implicit/Export/RayTrace.hs +46/−43
- Graphics/Implicit/Export/Render.hs +138/−189
- Graphics/Implicit/Export/Render/Definitions.hs +2/−4
- Graphics/Implicit/Export/Render/GetLoops.hs +24/−33
- Graphics/Implicit/Export/Render/GetSegs.hs +30/−78
- Graphics/Implicit/Export/Render/HandlePolylines.hs +34/−34
- Graphics/Implicit/Export/Render/HandleSquares.hs +32/−29
- Graphics/Implicit/Export/Render/Interpolate.hs +4/−6
- Graphics/Implicit/Export/Render/RefineSegs.hs +56/−47
- Graphics/Implicit/Export/Render/TesselateLoops.hs +29/−20
- Graphics/Implicit/Export/Symbolic/CoerceSymbolic2.hs +0/−29
- Graphics/Implicit/Export/Symbolic/CoerceSymbolic3.hs +0/−35
- Graphics/Implicit/Export/Symbolic/Rebound2.hs +3/−2
- Graphics/Implicit/Export/Symbolic/Rebound3.hs +3/−2
- Graphics/Implicit/Export/SymbolicFormats.hs +35/−24
- Graphics/Implicit/Export/SymbolicObj2.hs +36/−32
- Graphics/Implicit/Export/SymbolicObj3.hs +39/−45
- Graphics/Implicit/Export/TextBuilderUtils.hs +20/−30
- Graphics/Implicit/Export/TriangleMeshFormats.hs +68/−47
- Graphics/Implicit/Export/Util.hs +22/−18
- Graphics/Implicit/ExtOpenScad.hs +41/−28
- Graphics/Implicit/ExtOpenScad/Default.hs +185/−118
- Graphics/Implicit/ExtOpenScad/Definitions.hs +128/−42
- Graphics/Implicit/ExtOpenScad/Eval/Constant.hs +80/−0
- Graphics/Implicit/ExtOpenScad/Eval/Expr.hs +99/−59
- Graphics/Implicit/ExtOpenScad/Eval/Statement.hs +237/−110
- Graphics/Implicit/ExtOpenScad/Parser/Expr.hs +159/−255
- Graphics/Implicit/ExtOpenScad/Parser/Lexer.hs +141/−0
- Graphics/Implicit/ExtOpenScad/Parser/Statement.hs +133/−196
- Graphics/Implicit/ExtOpenScad/Parser/Util.hs +81/−74
- Graphics/Implicit/ExtOpenScad/Primitives.hs +260/−206
- Graphics/Implicit/ExtOpenScad/Util/ArgParser.hs +43/−35
- Graphics/Implicit/ExtOpenScad/Util/OVal.hs +44/−26
- Graphics/Implicit/ExtOpenScad/Util/StateC.hs +44/−44
- Graphics/Implicit/FastIntUtil.hs +30/−0
- Graphics/Implicit/IntegralUtil.hs +44/−0
- Graphics/Implicit/MathUtil.hs +25/−15
- Graphics/Implicit/ObjectUtil.hs +1/−3
- Graphics/Implicit/ObjectUtil/GetBox2.hs +255/−49
- Graphics/Implicit/ObjectUtil/GetBox3.hs +93/−51
- Graphics/Implicit/ObjectUtil/GetImplicit2.hs +20/−31
- Graphics/Implicit/ObjectUtil/GetImplicit3.hs +86/−62
- Graphics/Implicit/Primitives.hs +19/−21
- Makefile +0/−78
- README.md +0/−312
- docgen.hs +0/−88
- hacking.md +0/−174
- implicit.cabal +278/−235
- programs/Benchmark.hs +46/−29
- programs/ParserBench.hs +0/−61
- programs/docgen.hs +165/−0
- programs/extopenscad.hs +223/−98
- programs/implicitsnap.hs +115/−114
- programs/parser-bench.hs +155/−0
- stack.yaml +0/−29
- tests/ExecSpec/Expr.hs +28/−0
- tests/ExecSpec/Util.hs +35/−0
- tests/Main.hs +16/−6
- tests/MessageSpec/Message.hs +36/−0
- tests/MessageSpec/Util.hs +45/−0
- tests/NOTES +0/−2
- tests/ParserSpec/Expr.hs +120/−57
- tests/ParserSpec/Statement.hs +72/−50
- tests/ParserSpec/Util.hs +48/−17
- tests/tobacco_mesophyll_protoplast_fusion_device.escad +0/−493
− .gitignore
@@ -1,9 +0,0 @@-*~-*.o-*.hi-*.svg-*.png-*.ps-*.stl-dist/-Setup
− CONTRIBUTORS
@@ -1,28 +0,0 @@-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
@@ -1,4 +0,0 @@-union() {- square([80,80]);- translate ([80,80]) circle(30);-}
− Examples/example10.escad
@@ -1,2 +0,0 @@-// Example10.escad -- map!.-echo(map(cos, [0, pi/2, pi]));
− Examples/example11.hs
@@ -1,9 +0,0 @@--- 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
@@ -1,8 +0,0 @@--- 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
@@ -1,8 +0,0 @@--- 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
@@ -1,5 +0,0 @@-//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
@@ -1,10 +0,0 @@-// 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
@@ -1,10 +0,0 @@-// 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
@@ -1,10 +0,0 @@-// 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
@@ -1,10 +0,0 @@-// 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
@@ -1,10 +0,0 @@-// 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
@@ -1,7 +0,0 @@-// Example8.escad -- variable assignment in loops.-a = 5;-for (c = [1, 2, 3]) {- echo(c);- a = a*c;- echo(a);-}
− Examples/example9.escad
@@ -1,4 +0,0 @@-// Example9.escad -- function currying.-f = max(4);-echo(f(5));-echo(max(4,5));
Graphics/Implicit.hs view
@@ -2,76 +2,50 @@ -- Copyright (C) 2014 2015 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- FIXME: Required. why?-{-# 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 this haskell library. -} --- MAYBEFIXME: impliment slice operation , regularPolygon and zsurface primitives.--module Graphics.Implicit(- -- Operations- translate,- scale,- complement, union, intersect, difference,- unionR, intersectR, differenceR,- shell,- extrudeR,- extrudeRotateR,- extrudeRM,- extrudeOnEdgeOf,- -- Primitives- sphere,- rect3R,- circle,- cylinder,- cylinder2,- rectR,- polygonR,- rotateExtrude,- rotate3,- rotate3V,- pack3,- rotate,- pack2,- -- Export- writeSVG,- writeSTL,- writeBinSTL,- writeOBJ,- writeTHREEJS,- writeSCAD2,- writeSCAD3,- writeGCodeHacklabLaser,- writePNG2,- writePNG3,- runOpenscad,- implicit,- SymbolicObj2,- SymbolicObj3+module Graphics.Implicit (+ module P,+ module E,+ module W,+ writeSVG,+ writeDXF2,+ writeSTL,+ writeBinSTL,+ writeOBJ,+ writeTHREEJS,+ writeSCAD2,+ writeSCAD3,+ writeGCodeHacklabLaser,+ writePNG2,+ writePNG3 ) where import Prelude(FilePath, IO) -- The primitive objects, and functions for manipulating them.-import Graphics.Implicit.Primitives (translate, scale, complement, union, intersect, difference, unionR, intersectR, differenceR, shell, extrudeR, extrudeRM, extrudeRotateR, extrudeOnEdgeOf, sphere, rect3R, circle, cylinder, cylinder2, rectR, polygonR, rotateExtrude, rotate3, rotate3V, pack3, rotate, pack2, implicit)+-- MAYBEFIXME: impliment slice operation, regularPolygon and zsurface primitives.+import Graphics.Implicit.Primitives as P (translate, scale, complement, union, intersect, difference, unionR, intersectR, differenceR, shell, extrudeR, extrudeRM, extrudeRotateR, extrudeOnEdgeOf, sphere, rect3R, circle, cylinder, cylinder2, rectR, polygonR, rotateExtrude, rotate3, rotate3V, pack3, rotate, pack2, implicit) -- The Extended OpenScad interpreter.-import Graphics.Implicit.ExtOpenScad (runOpenscad)+import Graphics.Implicit.ExtOpenScad as E (runOpenscad) --- Functions for writing files based on the result of operations on primitives.-import qualified Graphics.Implicit.Export as Export (writeSVG, writeSTL, writeBinSTL, writeOBJ, writeSCAD2, writeSCAD3, writeTHREEJS, writeGCodeHacklabLaser, writePNG)+-- typesclasses and types defining the world, or part of the world.+import Graphics.Implicit.Definitions as W (ℝ, SymbolicObj2, SymbolicObj3) --- Datatypes/classes defining the world, or part of the world.-import Graphics.Implicit.Definitions (ℝ, SymbolicObj2, SymbolicObj3)+-- Functions for writing files based on the result of operations on primitives.+import qualified Graphics.Implicit.Export as Export (writeSVG, writeDXF2, writeSTL, writeBinSTL, writeOBJ, writeSCAD2, writeSCAD3, writeTHREEJS, writeGCodeHacklabLaser, writePNG) -- We want Export to be a bit less polymorphic -- (so that types will collapse nicely) writeSVG :: ℝ -> FilePath -> SymbolicObj2 -> IO () writeSVG = Export.writeSVG++writeDXF2 :: ℝ -> FilePath -> SymbolicObj2 -> IO ()+writeDXF2 = Export.writeDXF2 writeSTL :: ℝ -> FilePath -> SymbolicObj3 -> IO () writeSTL = Export.writeSTL
Graphics/Implicit/Definitions.hs view
@@ -10,23 +10,24 @@ {-# LANGUAGE FlexibleInstances #-} -- Definitions of the types used when modeling, and a few operators.- module Graphics.Implicit.Definitions (+ module F,+ module N, ℝ, ℝ2,+ both, ℝ3,+ allthree, minℝ,- ℕ,- Fastℕ, (⋅), (⋯*), (⋯/),- Polyline,- Polytri,- Triangle,- NormedTriangle,- TriangleMesh,- NormedTriangleMesh,+ Polyline(Polyline),+ Polytri(Polytri),+ Triangle(Triangle),+ NormedTriangle(NormedTriangle),+ TriangleMesh(TriangleMesh),+ NormedTriangleMesh(NormedTriangleMesh), Obj2, Obj3, Box2,@@ -69,41 +70,72 @@ ExtrudeRM, ExtrudeOnEdgeOf, RotateExtrude),- Rectilinear2,- Rectilinear3,+ fromℕtoℝ,+ fromFastℕtoℝ,+ fromℝtoFloat ) where -import Prelude (Show, Double, Integer, Int, Maybe, Either, show, (*), (/))+import Prelude (Show, Double, Either, show, (*), (/), fromIntegral, Float, realToFrac) +import Data.Maybe (Maybe)+ import Data.VectorSpace (Scalar, InnerSpace, (<.>)) +import Graphics.Implicit.FastIntUtil as F (Fastℕ(Fastℕ), fromFastℕ, toFastℕ)++import Graphics.Implicit.IntegralUtil as N (ℕ, fromℕ, toℕ)++import Control.DeepSeq (NFData, rnf)+ -- Let's make things a bit nicer. -- Following the math notation ℝ, ℝ², ℝ³...--- Supports changing Float to Double for more precision!--- FIXME: what about using rationals instead of Float/Double? type ℝ = Double type ℝ2 = (ℝ,ℝ) type ℝ3 = (ℝ,ℝ,ℝ) +-- | A give up point for dividing ℝs, and for the maximum difference between abs(n) and abs(-n). minℝ :: ℝ--- for Floats.---minℝ = 0.00000011920928955078125 * 2- -- for Doubles. minℝ = 0.0000000000000002+-- for Floats.+--minℝ = 0.00000011920928955078125 * 2 --- Arbitrary precision integers.-type ℕ = Integer+-- | apply a function to both items in the provided tuple.+both :: (t -> b) -> (t, t) -> (b, b)+both f (x,y) = (f x, f y)+{-# INLINABLE both #-} --- System integers.-type Fastℕ = Int+-- | apply a function to all three items in the provided tuple.+allthree :: (t -> b) -> (t, t, t) -> (b, b, b)+allthree f (x,y,z) = (f x, f y, f z)+{-# INLINABLE allthree #-} --- TODO: Find a better place for this+-- | TODO: Find a better place for this (⋅) :: InnerSpace a => a -> a -> Scalar a (⋅) = (<.>)+{-# INLINABLE (⋅) #-} --- add aditional instances to Show, for when we dump the intermediate form of an object.+-- Wrap the functions that convert datatypes.++-- | Convert from our Integral to our Rational. +fromℕtoℝ :: ℕ -> ℝ+fromℕtoℝ = fromIntegral+{-# INLINABLE fromℕtoℝ #-}++-- | Convert from our Fast Integer (int32) to ℝ.+fromFastℕtoℝ :: Fastℕ -> ℝ+fromFastℕtoℝ (Fastℕ a) = fromIntegral a+{-# INLINABLE fromFastℕtoℝ #-}++-- | Convert from our rational to a float, for output to a file.+fromℝtoFloat :: ℝ -> Float+fromℝtoFloat = realToFrac+{-# INLINABLE fromℝtoFloat #-}++-- | add aditional instances to Show, for when we dump the intermediate form of objects.+-- FIXME: store functions in a dumpable form!+-- These instances cover functions instance Show (ℝ -> ℝ) where show _ = "<function ℝ>" @@ -116,75 +148,90 @@ instance Show (ℝ3 -> ℝ) where show _ = "<collapse ℝ3 -> ℝ>" ---instance Show BoxedObj2 where--- show _ = "<BoxedObj2>"----instance Show BoxedObj3 where--- show _ = "<BoxedObj3>"- -- TODO: Find a better way to do this?+-- | Add multiply and divide operators for two ℝ2s or ℝ3s. class ComponentWiseMultable a where (⋯*) :: a -> a -> a (⋯/) :: a -> a -> a instance ComponentWiseMultable ℝ2 where (x,y) ⋯* (x',y') = (x*x', y*y')+ {-# INLINABLE (⋯*) #-} (x,y) ⋯/ (x',y') = (x/x', y/y')+ {-# INLINABLE (⋯/) #-} instance ComponentWiseMultable ℝ3 where (x,y,z) ⋯* (x',y',z') = (x*x', y*y', z*z')+ {-# INLINABLE (⋯*) #-} (x,y,z) ⋯/ (x',y',z') = (x/x', y/y', z/z')+ {-# INLINABLE (⋯/) #-} --- | A chain of line segments, as in SVG+-- | A chain of line segments, as in SVG or DXF. -- eg. [(0,0), (0.5,1), (1,0)] ---> /\-type Polyline = [ℝ2]+newtype Polyline = Polyline [ℝ2] -- | A triangle in 2D space (a,b,c).-type Polytri = (ℝ2, ℝ2, ℝ2)+newtype Polytri = 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)+newtype Triangle = 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))+newtype NormedTriangle = NormedTriangle ((ℝ3, ℝ3), (ℝ3, ℝ3), (ℝ3, ℝ3)) -- | A triangle mesh is a bunch of triangles, attempting to be a surface.-type TriangleMesh = [Triangle]+newtype TriangleMesh = TriangleMesh [Triangle] --- | A normed triangle mesh is a mesh of normed trianlges.-type NormedTriangleMesh = [NormedTriangle]+-- | A normed triangle mesh is a mesh of normed triangles.+newtype NormedTriangleMesh = NormedTriangleMesh [NormedTriangle] --- | A 2D object+instance NFData Triangle where+ rnf (Triangle (a,b,c)) = rnf (a,b,c)++instance NFData TriangleMesh where+ rnf (TriangleMesh xs) = rnf xs++instance NFData Polytri where+ rnf (Polytri (a,b,c)) = rnf (a,b,c)++instance NFData Polyline where+ rnf (Polyline xs) = rnf xs++-- | A 2D object. type Obj2 = (ℝ2 -> ℝ) --- | A 3D object+-- | A 3D object. type Obj3 = (ℝ3 -> ℝ) --- | A 2D box+-- | A 2D box. type Box2 = (ℝ2, ℝ2) --- | A 3D box+-- | A 3D box. type Box3 = (ℝ3, ℝ3) --- | A Box for containing a 2D object+-- | A Box containing a 2D object. type Boxed2 a = (a, Box2) --- | A Box for containing a 3D object+-- | A Box containing a 3D object. type Boxed3 a = (a, Box3) -- | A Boxed 2D object type BoxedObj2 = Boxed2 Obj2+--instance Show BoxedObj2 where+-- show _ = "<BoxedObj2>" -- | A Boxed 3D object type BoxedObj3 = Boxed3 Obj3+--instance Show BoxedObj3 where+-- show _ = "<BoxedObj3>" -- | A symbolic 2D object format.--- We want to have a symbolic object so that we can+-- We want to have symbolic objects so that we can -- accelerate rendering & give ideal meshes for simple -- cases. data SymbolicObj2 = -- Primitives- RectR ℝ ℝ2 ℝ2 -- rounding, start, stop.- | Circle ℝ -- radius+ RectR ℝ ℝ2 ℝ2 -- rounding, start, stop.+ | Circle ℝ -- radius. | PolygonR ℝ [ℝ2] -- rounding, points. -- (Rounded) CSG | Complement2 SymbolicObj2@@ -203,11 +250,11 @@ deriving Show -- | A symbolic 3D format!-data SymbolicObj3 = +data SymbolicObj3 = -- Primitives- Rect3R ℝ ℝ3 ℝ3- | Sphere ℝ- | Cylinder ℝ ℝ ℝ+ Rect3R ℝ ℝ3 ℝ3 -- rounding, start, stop.+ | Sphere ℝ -- radius+ | Cylinder ℝ ℝ ℝ -- -- (Rounded) CSG | Complement3 SymbolicObj3 | UnionR3 ℝ [SymbolicObj3]@@ -227,24 +274,18 @@ | ExtrudeR ℝ SymbolicObj2 ℝ | ExtrudeRotateR ℝ ℝ SymbolicObj2 ℝ | ExtrudeRM- ℝ -- rounding radius- (Maybe (ℝ -> ℝ)) -- twist- (Maybe (ℝ -> ℝ)) -- scale- (Maybe (ℝ -> ℝ2)) -- translate- SymbolicObj2 -- object to extrude- (Either ℝ (ℝ2 -> ℝ)) -- height to extrude to+ ℝ -- rounding radius+ (Either ℝ (ℝ -> ℝ)) -- twist+ (Either ℝ (ℝ -> ℝ)) -- scale+ (Either ℝ2 (ℝ -> ℝ2)) -- translate+ SymbolicObj2 -- object to extrude+ (Either ℝ (ℝ2 -> ℝ)) -- height to extrude to | RotateExtrude ℝ -- Angle to sweep to (Maybe ℝ) -- Loop or path (rounded corner)- (Either ℝ2 (ℝ -> ℝ2)) -- translate function- (Either ℝ (ℝ -> ℝ )) -- rotate function+ (Either ℝ2 (ℝ -> ℝ2)) -- translate+ (Either ℝ (ℝ -> ℝ )) -- rotate SymbolicObj2 -- object to extrude | ExtrudeOnEdgeOf SymbolicObj2 SymbolicObj2 deriving Show---- | Rectilinear 2D set-type Rectilinear2 = [Box2]---- | Rectilinear 3D set-type Rectilinear3 = [Box3]
Graphics/Implicit/Export.hs view
@@ -3,13 +3,10 @@ -- Copyright (C) 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 #-}---- FIXME: Required. why?+-- Allow us to use real types in the type constraints. {-# LANGUAGE FlexibleContexts #-} -module Graphics.Implicit.Export (writeObject, formatObject, writeSVG, writeSTL, writeBinSTL, writeOBJ, writeTHREEJS, writeGCodeHacklabLaser, writeSCAD3, writeSCAD2, writePNG) where+module Graphics.Implicit.Export (writeObject, formatObject, writeSVG, writeSTL, writeBinSTL, writeOBJ, writeTHREEJS, writeGCodeHacklabLaser, writeDXF2, writeSCAD2, writeSCAD3, writePNG) where import Prelude (FilePath, IO, (.), ($)) @@ -24,26 +21,26 @@ -- Import instances of DiscreteApproxable... import Graphics.Implicit.Export.DiscreteAproxable (DiscreteAproxable, discreteAprox) --- Object formats-import qualified Graphics.Implicit.Export.PolylineFormats as PolylineFormats (svg, hacklabLaserGCode)+-- Output file formats.+import qualified Graphics.Implicit.Export.PolylineFormats as PolylineFormats (svg, hacklabLaserGCode, dxf2) 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 (scad2, scad3) import qualified Codec.Picture as ImageFormatCodecs (DynamicImage, savePngImage) --- Write an object using the given format function.+-- | Write an object to a file with LazyText IO, using the given format writer function. writeObject :: (DiscreteAproxable obj aprox) => ℝ -- ^ Resolution- -> (aprox -> Text) -- ^ File Format (Function that formats)+ -> (aprox -> Text) -- ^ File Format Writer (Function that formats) -> FilePath -- ^ File Name -> obj -- ^ Object to render -> IO () -- ^ Writing Action!-writeObject res format filename obj =+writeObject res formatWriter filename obj = let- aprox = formatObject res format obj+ aprox = formatObject res formatWriter obj in LT.writeFile filename aprox --- Write an object using the given format writer.+-- | Serialize an object using the given format writer, which takes the filename and writes to it.. writeObject' :: (DiscreteAproxable obj aprox) => ℝ -- ^ Resolution -> (FilePath -> aprox -> IO ()) -- ^ File Format writer@@ -53,29 +50,33 @@ writeObject' res formatWriter filename obj = formatWriter filename (discreteAprox res obj) +-- | Serialize an object using the given format writer. No file target is implied. formatObject :: (DiscreteAproxable obj aprox) => ℝ -- ^ Resolution- -> (aprox -> Text) -- ^ File Format (Function that formats)+ -> (aprox -> Text) -- ^ File Format Writer (Function that formats) -> obj -- ^ Object to render -> Text -- ^ Resulting lazy ByteString-formatObject res format = format . discreteAprox res+formatObject res formatWriter = formatWriter . discreteAprox res -writeSVG :: forall obj. DiscreteAproxable obj [Polyline] => ℝ -> FilePath -> obj -> IO ()+writeSVG :: DiscreteAproxable obj [Polyline] => ℝ -> FilePath -> obj -> IO () writeSVG res = writeObject res PolylineFormats.svg -writeSTL :: forall obj. DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO ()+writeDXF2 :: DiscreteAproxable obj [Polyline] => ℝ -> FilePath -> obj -> IO ()+writeDXF2 res = writeObject res PolylineFormats.dxf2++writeSTL :: DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO () writeSTL res = writeObject res TriangleMeshFormats.stl -writeBinSTL :: forall obj. DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO ()+writeBinSTL :: DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO () writeBinSTL res file obj = LBS.writeFile file $ TriangleMeshFormats.binaryStl $ discreteAprox res obj -writeOBJ :: forall obj. DiscreteAproxable obj NormedTriangleMesh => ℝ -> FilePath -> obj -> IO ()+writeOBJ :: DiscreteAproxable obj NormedTriangleMesh => ℝ -> FilePath -> obj -> IO () writeOBJ res = writeObject res NormedTriangleMeshFormats.obj -writeTHREEJS :: forall obj. DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO ()+writeTHREEJS :: DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO () writeTHREEJS res = writeObject res TriangleMeshFormats.jsTHREE -writeGCodeHacklabLaser :: forall obj. DiscreteAproxable obj [Polyline] => ℝ -> FilePath -> obj -> IO ()+writeGCodeHacklabLaser :: DiscreteAproxable obj [Polyline] => ℝ -> FilePath -> obj -> IO () writeGCodeHacklabLaser res = writeObject res PolylineFormats.hacklabLaserGCode writeSCAD3 :: ℝ -> FilePath -> SymbolicObj3 -> IO ()@@ -84,5 +85,5 @@ writeSCAD2 :: ℝ -> FilePath -> SymbolicObj2 -> IO () writeSCAD2 res filename obj = LT.writeFile filename $ SymbolicFormats.scad2 res obj -writePNG :: forall obj. DiscreteAproxable obj ImageFormatCodecs.DynamicImage => ℝ -> FilePath -> obj -> IO ()+writePNG :: DiscreteAproxable obj ImageFormatCodecs.DynamicImage => ℝ -> FilePath -> obj -> IO () writePNG res = writeObject' res ImageFormatCodecs.savePngImage
Graphics/Implicit/Export/DiscreteAproxable.hs view
@@ -5,31 +5,41 @@ -- Allow our DiscreteAproxable class to handle multiple parameters. {-# LANGUAGE MultiParamTypeClasses #-} --- FIXME: why is this here?-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+-- For the instance declaration of DiscreteAproxable SymbolicObj2 [Polyline]+{-# LANGUAGE FlexibleInstances #-} +-- | A module for retrieving approximate represententations of objects. module Graphics.Implicit.Export.DiscreteAproxable (DiscreteAproxable, discreteAprox) where -import Prelude((-), (/), ($), (<), map, round, (+), maximum, abs, (*), fromIntegral, max, realToFrac)+import Prelude((-), (/), ($), (<), fmap, round, (+), maximum, abs, (*), fromIntegral, max, realToFrac, Int) -import Graphics.Implicit.Definitions (ℝ, Fastℕ, ℝ2, SymbolicObj2, SymbolicObj3, Polyline, TriangleMesh, NormedTriangleMesh)+-- Definitions for our number system, objects, and the things we can use to approximately represent objects.+import Graphics.Implicit.Definitions (ℝ, ℝ2, SymbolicObj2, SymbolicObj3, Polyline, Triangle, TriangleMesh(TriangleMesh), NormedTriangleMesh(NormedTriangleMesh)) -import Graphics.Implicit.ObjectUtil (getImplicit3, getImplicit2, getBox3, getBox2)+import Graphics.Implicit.ObjectUtil (getImplicit2, getImplicit3, getBox2, getBox3) import Graphics.Implicit.Export.SymbolicObj3 (symbolicGetMesh)+ import Graphics.Implicit.Export.SymbolicObj2 (symbolicGetContour)-import Graphics.Implicit.Export.Util (normTriangle) - -import Graphics.Implicit.Export.RayTrace (dynamicImage, Color, average, Camera(Camera), Light(Light), Scene(Scene), traceRay, cameraRay) -import Codec.Picture (DynamicImage, generateImage, PixelRGBA8(PixelRGBA8))+import Graphics.Implicit.Export.Util (normTriangle) +-- We are the only ones that use this.+import Graphics.Implicit.Export.RayTrace (Color(Color), Camera(Camera), Light(Light), Scene(Scene), average, traceRay, cameraRay)++import Codec.Picture (DynamicImage(ImageRGBA8), PixelRGBA8(PixelRGBA8), generateImage)+ import Data.VectorSpace ((^+^), (^/), (*^), (^-^))+ import Data.AffineSpace ((.-^), (.+^)) +default (ℝ) +unmesh :: TriangleMesh -> [Triangle]+unmesh (TriangleMesh m) = m+ -- | There is a discrete way to aproximate this object.--- eg. Aproximating a 3D object with a tirangle mesh+-- eg. Aproximating a 3D object with a triangle mesh -- would be DiscreteApproxable Obj3 TriangleMesh class DiscreteAproxable obj aprox where discreteAprox :: ℝ -> obj -> aprox@@ -38,68 +48,77 @@ discreteAprox = symbolicGetMesh instance DiscreteAproxable SymbolicObj3 NormedTriangleMesh where- discreteAprox res obj = map (normTriangle res (getImplicit3 obj)) $ symbolicGetMesh res obj+ discreteAprox res obj = NormedTriangleMesh $ fmap (normTriangle res (getImplicit3 obj)) $ unmesh $ symbolicGetMesh res obj --- FIXME: magic numbers.+-- FIXME: way too many magic numbers.+-- FIXME: adjustable resolution! instance DiscreteAproxable SymbolicObj3 DynamicImage where- discreteAprox _ symbObj = dynamicImage $ generateImage pixelRenderer (round w) (round h)+ discreteAprox _ symbObj = ImageRGBA8 $ generateImage pixelRenderer (round w) (round h) where+ -- | Size of the image to produce. (w,h) = (150, 150) :: ℝ2 obj = getImplicit3 symbObj box@((x1,y1,z1), (_,y2,z2)) = getBox3 symbObj av :: ℝ -> ℝ -> ℝ- av a b = (a+b)/(2::ℝ)+ av a b = (a+b)/2 avY = av y1 y2 avZ = av z1 z2 deviation = maximum [abs $ y1 - avY, abs $ y2 - avY, abs $ z1 - avZ, abs $ z2 - avZ]- camera = Camera (x1-deviation*(2.2::ℝ), avY, avZ) (0, -1, 0) (0,0, -1) 1.0- lights = [Light (x1-deviation*(1.5::ℝ), y1 - (0.4::ℝ)*(y2-y1), avZ) ((0.03::ℝ)*deviation) ]- scene = Scene obj (PixelRGBA8 200 200 230 255) lights (PixelRGBA8 255 255 255 0)- pixelRenderer :: Fastℕ -> Fastℕ -> Color- pixelRenderer a b = renderScreen - ((fromIntegral a :: ℝ)/w - (0.5::ℝ)) ((fromIntegral b :: ℝ)/h - (0.5 ::ℝ))- renderScreen :: ℝ -> ℝ -> Color+ 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 (Color 200 200 230 255) lights (Color 255 255 255 0)+ -- | passed to generateImage, it's external, and determines this type.+ pixelRenderer :: Int -> Int -> PixelRGBA8+ pixelRenderer a b = renderScreen+ (fromIntegral a/w - 0.5) (fromIntegral b/h - 0.5)+ renderScreen :: ℝ -> ℝ -> PixelRGBA8 renderScreen a b =+ colorToPixelRGBA8 $ average [- traceRay + traceRay (cameraRay camera ((a,b) ^+^ ( 0.25/w, 0.25/h))) 2 box scene,- traceRay + traceRay (cameraRay camera ((a,b) ^+^ (-0.25/w, 0.25/h))) 0.5 box scene,- traceRay + traceRay (cameraRay camera ((a,b) ^+^ (0.25/w, -0.25/h))) 0.5 box scene,- traceRay + traceRay (cameraRay camera ((a,b) ^+^ (-0.25/w,-0.25/h))) 0.5 box scene ]+ where+ colorToPixelRGBA8 :: Color -> PixelRGBA8+ colorToPixelRGBA8 (Color rr gg bb aa) = PixelRGBA8 rr gg bb aa instance DiscreteAproxable SymbolicObj2 [Polyline] where discreteAprox = symbolicGetContour +-- FIXME: way too many magic numbers.+-- FIXME: adjustable resolution? instance DiscreteAproxable SymbolicObj2 DynamicImage where- discreteAprox _ symbObj = dynamicImage $ generateImage pixelRenderer (round w) (round h)+ discreteAprox _ symbObj = ImageRGBA8 $ generateImage pixelRenderer (round w) (round h) where+ -- | Size of the image to produce. (w,h) = (150, 150) :: ℝ2 obj = getImplicit2 symbObj (p1@(x1,_), p2@(_,y2)) = getBox2 symbObj (dx, dy) = p2 ^-^ p1 dxy = max dx dy- pixelRenderer :: Fastℕ -> Fastℕ -> Color+ -- | passed to generateImage, it's external, and determines this type.+ pixelRenderer :: Int -> Int -> PixelRGBA8 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- mycolor = average [objColor $ xy a' b', objColor $ xy a' b',+ mycolor = colorToPixelRGBA8 $ average [objColor $ xy a' b', objColor $ xy a' b', objColor $ xy (a'+s) (b'+s), objColor $ xy (a'-s) (b'-s), objColor $ xy (a'+s) (b'+s), objColor $ xy (a'-s) (b'-s)]- objColor p = if obj p < 0 then PixelRGBA8 150 150 160 255 else PixelRGBA8 255 255 255 0---+ colorToPixelRGBA8 :: Color -> PixelRGBA8+ colorToPixelRGBA8 (Color rr gg bb aa) = PixelRGBA8 rr gg bb aa+ objColor p = if obj p < 0 then Color 150 150 160 255 else Color 255 255 255 0 -
− Graphics/Implicit/Export/MarchingSquares.hs
@@ -1,218 +0,0 @@--- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)--- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)--- Released under the GNU AGPLV3+, see LICENSE---- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}---- export getContour, which returns as array of polylines describing the edge of a 2D object.-module Graphics.Implicit.Export.MarchingSquares (getContour) where--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 Data.VectorSpace ((^-^), (^+^))--import Control.Arrow((***))---- 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 res obj =- let- -- How much space are we rendering?- d = p2 ^-^ p1-- -- How many steps will we take on each axis?- 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] ] `using` parBuffer (max 1 $ fromIntegral $ div ny 32) rdeepseq-- -- Cleanup, cleanup, everybody cleanup!- -- (We connect multilines, delete redundant vertices on them, etc)- lines = filter polylineNotNull $ map reducePolyline $ orderLinesDC linesOnGrid- in- lines--- FIXME: Commented out, not used?-{-- -- 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))- -- Evaluate obj on a grid, in parallel.- valsOnGrid :: [[ℝ]]- valsOnGrid = [[ obj (fromGrid (mx, my)) | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]- `using` parList rdeepseq- -- A faster version of the obj. Sort of like memoization, but done in advance, in parallel.- preEvaledObj p = valsOnGrid !! my !! mx where (mx,my) = toGrid p- -- Divide it up and compute the polylines- linesOnGrid :: [[[Polyline]]]- linesOnGrid = [[getSquareLineSegs (fromGrid (mx, my)) (fromGrid (mx+1, my+1)) preEvaledObj- | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]--}---- | This function gives line segments to divide negative interior--- 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.--getSquareLineSegs :: ℝ2 -> ℝ2 -> Obj2 -> [Polyline]-getSquareLineSegs (x1, y1) (x2, y2) obj =- let- (x,y) = (x1, y1)-- -- 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- dy = y2 - y1-- -- linearly interpolated midpoints on the relevant axis- -- midy2- -- _________*__________- -- | |- -- | |- -- | |- --midx1* * midx2- -- | |- -- | |- -- | |- -- ---------*----------- -- midy1--- midx1 = (x, y + dy*x1y1/(x1y1-x1y2))- midx2 = (x + dx, y + dy*x2y1/(x2y1-x2y2))- midy1 = (x + dx*x1y1/(x1y1-x2y1), y )- midy2 = (x + dx*x1y2/(x1y2-x2y2), y + dy)-- notPointLine :: Eq a => [a] -> Bool- 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,- True, True) -> []- (False, False,- False, False) -> []- (True, True,- False, False) -> [[midx1, midx2]]- (False, False,- True, True) -> [[midx1, midx2]]- (False, True,- False, True) -> [[midy1, midy2]]- (True, False,- True, False) -> [[midy1, midy2]]- (True, False,- False, False) -> [[midx1, midy2]]- (False, True,- True, True) -> [[midx1, midy2]]- (True, True,- False, True) -> [[midx1, midy1]]- (False, False,- True, False) -> [[midx1, midy1]]- (True, True,- True, False) -> [[midx2, midy1]]- (False, False,- False, True) -> [[midx2, midy1]]- (True, False,- True, True) -> [[midx2, midy2]]- (False, True,- False, False) -> [[midx2, midy2]]- (True, False,- False, True) -> if c > 0- then [[midx1, midy2], [midx2, midy1]]- else [[midx1, midy1], [midx2, midy2]]- (False, True,- True, False) -> if c <= 0- then [[midx1, midy2], [midx2, midy1]]- else [[midx1, midy1], [midx2, midy2]]----- Functions for cleaning up the polylines--- Many have multiple implementations as efficiency experiments.--- At some point, we'll get rid of the redundant ones....--{--orderLines :: [Polyline] -> [Polyline]-orderLines [] = []-orderLines (present:remaining) =- let- findNext ((p3:ps):segs) = if p3 == last present then (Just (p3:ps), segs) else- if last ps == last present then (Just (reverse $ p3:ps), segs) else- case findNext segs of (res1,res2) -> (res1,(p3:ps):res2)- findNext [] = (Nothing, [])- in- case findNext remaining of- (Nothing, _) -> present:(orderLines remaining)- (Just match, others) -> orderLines $ (present ++ tail match): others--}--orderLinesDC :: [[[Polyline]]] -> [Polyline]-orderLinesDC segs =- let- halve :: [a] -> ([a], [a])- halve l = splitAt (div (length l) 2) l- 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- splitOrder segs-{--orderLinesP :: [[[Polyline]]] -> [Polyline]-orderLinesP segs =- let- halve l = splitAt (div (length l) 2) l- splitOrder segs = case (\(x,y) -> (halve x, halve y)) $ unzip $ map (halve) segs of- ((a,b),(c,d)) -> orderLinesDC a ++ orderLinesDC b ++ orderLinesDC c ++ orderLinesDC d- -- force is frome real world haskell- force xs = go xs `pseq` ()- where go (_:xs) = go xs- go [] = 1- in- if (length segs < 5 || length (head segs) < 5 ) then concat $ concat segs else- case (\(x,y) -> (halve x, halve y)) $ unzip $ map (halve) segs of- ((a,b),(c,d)) -> orderLines $- let- a' = orderLinesP a- b' = orderLinesP b- c' = orderLinesP c- d' = orderLinesP d- in (force a' `par` force b' `par` force c' `par` force d') `pseq`- (a' ++ b' ++ c' ++ d')--}---polylineNotNull :: [a] -> Bool-polylineNotNull (_:l) = not (null l)-polylineNotNull [] = False-
Graphics/Implicit/Export/MarchingSquaresFill.hs view
@@ -2,53 +2,61 @@ -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}---- export getContourMesh, which returns an array of triangles describing the interior of a 2D object.+-- exports 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), fromIntegral, ($), (-), (+), (/), (*), (<=), (>), ceiling, concat, max, div)+import Prelude(Bool(True, False), ($), (-), (+), (/), (*), (<=), ceiling, max, div, floor) -import Graphics.Implicit.Definitions (ℕ, ℝ2, Polytri, Obj2, (⋯/), (⋯*))+import Graphics.Implicit.Definitions (ℕ, ℝ, ℝ2, both, Polytri(Polytri), Obj2, (⋯/), (⋯*), fromℕtoℝ, fromℕ) import Data.VectorSpace ((^-^),(^+^)) --- Each step on the Y axis is done in parallel using Control.Parallel.Strategies-import Control.Parallel.Strategies (using, rdeepseq, parBuffer)+import Data.List(genericIndex) --- 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)+import Data.Foldable (fold) +-- Each step on the Y axis is done in parallel using Control.Parallel.Strategies+import Control.Parallel.Strategies (using, rdeepseq, parBuffer, parList)++-- | Get an array of triangles describing the interior of a 2D object. getContourMesh :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [Polytri] getContourMesh p1 p2 res obj = let- -- How much space are we rendering?+ -- | How much space are we rendering? d = p2 ^-^ p1 - -- How many steps will we take on each axis?+ -- | How many steps will we take on each axis? nx :: ℕ ny :: ℕ- n@(nx,ny) = (ceiling) `both` (d ⋯/ res)+ n@(nx,ny) = ceiling `both` (d ⋯/ res) - -- a helper for calculating a position inside of the space.+ -- | A helper for calculating a position inside of the space. gridPos :: (ℕ,ℕ) -> (ℕ,ℕ) -> ℝ2- gridPos n' m = p1 ^+^ d ⋯* ((fromIntegral `both` m) ⋯/ (fromIntegral `both` n'))+ gridPos n' m = p1 ^+^ d ⋯* ((fromℕtoℝ `both` m) ⋯/ (fromℕtoℝ `both` n')) - -- compute the triangles.+ -- | Alternate Grid mapping funcs+ toGrid :: ℝ2 -> (ℕ,ℕ)+ toGrid f = floor `both` ((fromℕtoℝ `both` n) ⋯* (f ^-^ p1) ⋯/ d)++ -- | Evaluate obj on a grid, in parallel.+ valsOnGrid :: [[ℝ]]+ valsOnGrid = [[ obj $ gridPos n (mx, my) | mx <- [0..nx-1] ] | my <- [0..ny-1] ] `using` parList rdeepseq++ -- | A faster version of the obj. Sort of like memoization, but done in advance, in parallel.+ preEvaledObj p = valsOnGrid `genericIndex` my `genericIndex` mx where (mx,my) = toGrid p++ -- | 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+ trisOnGrid = [[getSquareTriangles (gridPos n (mx,my)) (gridPos n (mx+1,my+1)) preEvaledObj+ | mx <- [0..nx-1] ] | my <- [0..ny-1] ] `using` parBuffer (max 1 $ fromℕ $ div ny 32) rdeepseq+ -- FIXME: merge adjacent triangles.+ triangles = fold $ fold trisOnGrid in triangles --- | This function gives line segments to divide negative interior--- regions and positive exterior ones inside a square, based on its--- values at its vertices.--- It is based on the linearly-interpolated marching squares algorithm.-+-- | This function returns triangles covering a portion of the interior of an object.+-- The triangles are defined in a clockwise fashion, beginning on the point closest to origin, or failing that, the closest point to x1 on the x axis.+-- It is based on the linearly-interpolated marching squares algorithm. getSquareTriangles :: ℝ2 -> ℝ2 -> Obj2 -> [Polytri] getSquareTriangles (x1, y1) (x2, y2) obj = let@@ -63,75 +71,55 @@ -- And the center point.. c = obj ((x1+x2)/2, (y1+y2)/2) + -- Assumptions:+ -- FIXME: interpolations for C?+ -- Evaluating obj is expensive, only evaluate C when it being positive will increase/decrease the surface area by 50% or more.+ dx = x2 - x1 dy = y2 - y1 - -- linearly interpolated midpoints on the relevant axis- -- midy2- -- _________*_________+ -- linearly interpolated intersections on the relevant axis:+ -- (x1,y1) inty1 (x2,y1)+ -- *_________*_________* -- | | -- | | -- | |- --midx1* * midx2+ --intx1* *c *intx2 -- | | -- | | -- | |- -- ---------*---------- -- midy1+ -- *---------*---------*+ -- (x1,y2) inty2 (x2,y2) - 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)+ -- These intersections are where the edge of the object crosses the axis, not the middle of the axis.+ intx1 = (x, y + dy*x1y1/(x1y1-x1y2))+ intx2 = (x + dx, y + dy*x2y1/(x2y1-x2y2))+ inty1 = (x + dx*x1y1/(x1y1-x2y1), y )+ inty2 = (x + dx*x1y2/(x1y2-x2y2), y + dy) -- decompose a square into two triangles...- square :: forall t t1. t -> t1 -> t1 -> t1 -> [(t, t1, t1)]- square aa bb cc dd = [(aa,bb,cc), (aa,cc,dd)]+ square :: ℝ2 -> ℝ2 -> ℝ2 -> ℝ2 -> [Polytri]+ square aa bb cc dd = [Polytri (aa,bb,cc), Polytri (aa,cc,dd)] - in case (x1y2 <= 0, x2y2 <= 0,- x1y1 <= 0, x2y1 <= 0) of+ in case (x1y1 <= 0, x2y1 <= 0, x2y2 <= 0, x1y2 <= 0, c <= 0) of -- Yes, there's some symetries that could reduce the amount of code... -- But I don't think they're worth exploiting...- (True, True,- True, True) -> square (x1,y1) (x2,y1) (x2,y2) (x1,y2)- (False, False,- False, False) -> []- (True, True,- False, False) -> square midx1 midx2 (x2,y2) (x1,y2)- (False, False,- True, True) -> square (x1,y1) (x2,y1) midx2 midx1- (False, True,- False, True) -> square midy1 (x2,y1) (x2,y2) midy2- (True, False,- True, False) -> square (x1,y1) midy1 midy2 (x1,y2)- (True, False,- False, False) -> [((x1,y2), midx1, midy2)]- (False, True,- True, True) ->- [(midx1, (x1,y1), midy2), ((x1,y1), (x2,y1), midy2), (midy2, (x2,y1), (x2,y2))]- (True, True,- False, True) ->- [((x1,y2), midx1, (x2,y2)), (midx1, midy1, (x2,y2)), ((x2,y2), midy1, (x2,y1))]- (False, False,- True, False) -> [(midx1, (x1,y1), midy1)]- (True, True,- True, False) ->- [(midy1,midx2,(x2,y2)), ((x2,y2), (x1,y2), midy1), (midy1, (x1,y2), (x1,y1))]- (False, False,- False, True) -> [(midx2, midy1, (x2,y1))]- (True, False,- True, True) ->- [(midy2, (x2,y1), midx2), ((x2,y1), midy2, (x1,y1)), ((x1,y1), midy2, (x1,y2))]- (False, True,- False, False) -> [(midx2, (x2,y2), midy2)]- (True, False,- False, True) -> if c > 0- then [((x1,y2), midx1, midy2), ((x2,y1), midy1, midx2)] --[[midx1, midy2], [midx2, midy1]]- else [] --[[midx1, midy1], [midx2, midy2]]- (False, True,- True, False) -> if c <= 0- then [] --[[midx1, midy2], [midx2, midy1]]- else [((x1,y1), midy1, midx1), ((x2,y2), midx2, midy2)] --[[midx1, midy1], [midx2, midy2]]--+ (False, False, False, False, _) -> []+ ( True, True, True, True, _) -> square (x1,y1) (x2,y1) (x2,y2) (x1,y2)+ ( True, True, False, False, _) -> square (x1,y1) (x2,y1) intx2 intx1+ (False, True, True, False, _) -> square inty1 (x2,y1) (x2,y2) inty2+ (False, False, True, True, _) -> square intx1 intx2 (x2,y2) (x1,y2)+ ( True, False, False, True, _) -> square (x1,y1) inty1 inty2 (x1,y2)+ (False, False, False, True, _) -> [Polytri ( intx1 , inty2 , (x1,y2))]+ (False, False, True, False, _) -> [Polytri ( intx2 , (x2,y2), inty2 )]+ (False, True, False, False, _) -> [Polytri ( inty1 , (x2,y1), intx1 )]+ ( True, False, False, False, _) -> [Polytri ((x1,y1), inty1 , intx1 )]+ (False, True, True, True, _) -> [Polytri ( intx1 , (x2,y2), (x1,y2)), Polytri ( inty1 , (x2,y2), intx1 ), Polytri ( inty1 , (x2,y1), (x2,y2))]+ ( True, False, True, True, _) -> [Polytri ((x1,y1), inty1 , (x1,y2)), Polytri ( inty1 , intx2 , (x1,y2)), Polytri ( intx2 , (x2,y2), (x1,y2))]+ ( True, True, False, True, _) -> [Polytri ((x1,y1), inty2 , (x1,y2)), Polytri ((x1,y1), intx2 , inty2 ), Polytri ((x1,y1), (x2,y1), intx2 )]+ ( True, True, True, False, _) -> [Polytri ((x1,y1), (x2,y1), intx1 ), Polytri ( intx1 , (x2,y1), inty2 ), Polytri ((x2,y1), (x2,y2), inty2 )]+ (False, True, False, True, False) -> [Polytri ( inty1 , (x1,y2), intx1 ), Polytri ((x2,y1), inty2 , intx2 )]+ (False, True, False, True, True) -> [Polytri ( inty1 , (x1,y2), intx1 ), Polytri ((x2,y1), inty2 , intx2 ), Polytri ( inty1 , (x2,y1), (x1,y2)), Polytri ((x2,y1), inty2, (x1,y2))]+ ( True, False, True, False, False) -> [Polytri ((x1,y1), inty1 , intx2 ), Polytri ( intx1 , (x2,y2), inty2 )]+ ( True, False, True, False, True) -> [Polytri ((x1,y1), inty1 , intx2 ), Polytri ( intx1 , (x2,y2), inty2 ), Polytri ((x1,y1), intx2 , (x2,y2)), Polytri ((x1,y1), (x2,y2), intx1)]
Graphics/Implicit/Export/NormedTriangleMeshFormats.hs view
@@ -7,39 +7,42 @@ module Graphics.Implicit.Export.NormedTriangleMeshFormats (obj) where -import Prelude(($), map, (+), (.), (*), length, (-), return)+import Prelude(($), fmap, (+), (.), (*), length, (-), pure, (<>)) -import Graphics.Implicit.Definitions (NormedTriangle, ℝ3)-import Graphics.Implicit.Export.TextBuilderUtils (Text, Builder, toLazyText, (<>), bf, mconcat, buildInt)+import Graphics.Implicit.Definitions (NormedTriangle(NormedTriangle), NormedTriangleMesh(NormedTriangleMesh), ℝ3)+import Graphics.Implicit.Export.TextBuilderUtils (Text, Builder, toLazyText, bf, buildInt) +import Data.Foldable (fold, foldMap) -obj :: [NormedTriangle] -> Text-obj normedtriangles = toLazyText $ vertcode <> normcode <> trianglecode+-- | Generate a .obj format file from a NormedTriangleMesh+-- see: https://en.wikipedia.org/wiki/Wavefront_.obj_file+obj :: NormedTriangleMesh -> Text+obj (NormedTriangleMesh normedtriangles) = toLazyText $ vertcode <> normcode <> trianglecode where- -- A vertex line; v (0.0, 0.0, 1.0) = "v 0.0 0.0 1.0\n"+ -- | A vertex line; v (0.0, 0.0, 1.0) = "v 0.0 0.0 1.0\n" v :: ℝ3 -> Builder v (x,y,z) = "v " <> bf x <> " " <> bf y <> " " <> bf z <> "\n"- -- A normal line; n (0.0, 0.0, 1.0) = "vn 0.0 0.0 1.0\n"+ -- | A normal line; n (0.0, 0.0, 1.0) = "vn 0.0 0.0 1.0\n" n :: ℝ3 -> Builder n (x,y,z) = "vn " <> bf x <> " " <> bf y <> " " <> bf z <> "\n" verts = do- -- extract the vertices for each triangle- -- recall that a normed triangle is of the form ((vert, norm), ...)- ((a,_),(b,_),(c,_)) <- normedtriangles- -- The vertices from each triangle take up 3 position in the resulting list+ -- | Extract the vertices for each triangle+ -- recall that a normed triangle is of the form ((vert, norm), ...)+ NormedTriangle ((a,_),(b,_),(c,_)) <- normedtriangles+ -- | The vertices from each triangle take up 3 positions in the resulting list [a,b,c] norms = do- -- extract the normals for each triangle- ((_,a),(_,b),(_,c)) <- normedtriangles- -- The normals from each triangle take up 3 position in the resulting list+ -- | extract the normals for each triangle+ NormedTriangle ((_,a),(_,b),(_,c)) <- normedtriangles+ -- | The normals from each triangle take up 3 positions in the resulting list [a,b,c]- vertcode = mconcat $ map v verts- normcode = mconcat $ map n norms- trianglecode = mconcat $ do- n' <- map ((+1).(*3)) [0,1 .. length normedtriangles -1]+ vertcode = foldMap v verts+ normcode = foldMap n norms+ trianglecode = fold $ do+ n' <- fmap ((+1).(*3)) [0,1 .. length normedtriangles -1] let vta = buildInt n' vtb = buildInt (n'+1) vtc = buildInt (n'+2)- return $ "f " <> vta <> " " <> vtb <> " " <> vtc <> " " <> "\n"+ pure $ "f " <> vta <> " " <> vtb <> " " <> vtc <> " " <> "\n"
Graphics/Implicit/Export/PolylineFormats.hs view
@@ -2,89 +2,156 @@ -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}- {-# LANGUAGE OverloadedStrings #-} -module Graphics.Implicit.Export.PolylineFormats (svg, hacklabLaserGCode) where+module Graphics.Implicit.Export.PolylineFormats (svg, hacklabLaserGCode, dxf2) where -import Prelude((.), ($), (-), (+), (/), minimum, maximum, unzip, concat, show, (++), unwords, map, mapM_, snd, compare, min, max)+import Prelude((.), ($), (-), (+), (/), minimum, maximum, unzip, show, unwords, fmap, snd, compare, min, max, length, foldl, mempty, (<>)) -import Graphics.Implicit.Definitions (Polyline, ℝ, ℝ2)+import Graphics.Implicit.Definitions (Polyline(Polyline), ℝ, ℝ2) -import Graphics.Implicit.Export.TextBuilderUtils (Text, Builder, mempty, toLazyText, mconcat, bf, (<>), buildTruncFloat)+import Graphics.Implicit.Export.TextBuilderUtils (Text, Builder, toLazyText, bf, buildInt, buildTruncFloat) import Text.Blaze.Svg.Renderer.Text (renderSvg)-import Text.Blaze.Svg11 ((!),docTypeSvg,g,polyline,toValue)+import Text.Blaze.Svg11 ((!),docTypeSvg,g,polyline,toValue,Svg) import Text.Blaze.Internal (stringValue)-import qualified Text.Blaze.Svg11.Attributes as A+import qualified Text.Blaze.Svg11.Attributes as A (version, width, height, viewbox, points, stroke, strokeWidth, fill) import Data.List (sortBy) +import Data.Foldable (fold, foldMap, traverse_)++default (ℝ)++-- FIXME: magic numbers. svg :: [Polyline] -> Text svg plines = renderSvg . svg11 . svg' $ plines where strokeWidth :: ℝ- strokeWidth = 1.0- (xmin, xmax, ymin, ymax) = (minimum xs - margin, maximum xs + margin, minimum ys - margin, maximum ys + margin)+ strokeWidth = 1+ (xmin, xmax, ymin, ymax) = (xmin' - margin, xmax' + margin, ymin' - margin, ymax' + margin) where margin = strokeWidth / 2- (xs,ys) = unzip (concat plines)- + ((xmin', xmax'), (ymin', ymax')) = (maxMinList xs,maxMinList ys)+ (xs,ys) = unzip $ foldMap pair plines+ pair (Polyline a) = a+ maxMinList :: [ℝ] -> (ℝ,ℝ)+ maxMinList (x:others) = foldl (\(l,h) y -> (min l y, max h y)) (x,x) others+ maxMinList [] = (0,0) 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])+ ! A.width (stringValue $ show (xmax-xmin) <> "mm")+ ! A.height (stringValue $ show (ymax-ymin) <> "mm")+ ! A.viewbox (stringValue $ unwords . fmap 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 + svg' :: [Polyline] -> Svg+ svg' [] = mempty -- When we have a known point, we can compute said transformation:- svg' polylines = thinBlueGroup $ mapM_ poly polylines+ svg' polylines = thinBlueGroup $ traverse_ poly polylines - poly line = polyline ! A.points pointList - where pointList = toValue $ toLazyText $ mconcat [bf (x-xmin) <> "," <> bf (ymax - y) <> " " | (x,y) <- line]+ poly (Polyline line) = polyline ! A.points pointList+ where pointList = toValue $ toLazyText $ fold [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 (stringValue $ show strokeWidth) ! A.fill "none" -- obj +-- | DXF2 export in 2D. conforming to AutoCAD R12/13.+dxf2 :: [Polyline] -> Text+dxf2 plines = toLazyText $ dxf2Header <> dxf2Tables <> dxf2Blocks <> dxf2Entities+ where+ dxf2Header :: Builder+ dxf2Header =+ " 0\n" <> "SECTION\n" <>+ " 2\n" <> "HEADER\n" <>+ " 9\n" <> "$ACADVER\n" <>+ " 1\n" <> "AC1009\n" <>+ " 9\n" <> "$LIMMIN\n" <>+ " 10\n" <> buildTruncFloat dxfxmin <> "\n" <>+ " 20\n" <> buildTruncFloat dxfymin <> "\n" <>+ " 9\n" <> "$LIMMAX\n" <>+ " 10\n" <> buildTruncFloat dxfxmax <> "\n" <>+ " 20\n" <> buildTruncFloat dxfymax <> "\n" <>+ " 9\n" <> "$LUPREC\n" <>+ " 70\n" <> "4\n" <>+ " 0\n" <> "ENDSEC\n"+ dxf2Tables :: Builder+ dxf2Tables =+ " 0\n" <> "SECTION\n" <>+ " 2\n" <> "TABLES\n" <>+ " 0\n" <> "ENDSEC\n"+ dxf2Blocks :: Builder+ dxf2Blocks =+ " 0\n" <> "SECTION\n" <>+ " 2\n" <> "BLOCKS\n" <>+ " 0\n" <> "ENDSEC\n"+ dxf2Entities :: Builder+ dxf2Entities =+ " 0\n" <> "SECTION\n" <>+ " 2\n" <> "ENTITIES\n" <>+ foldMap buildPolyline (orderPolylines plines) <>+ " 0\n" <> "ENDSEC\n"+ buildPolyline :: Polyline -> Builder+ buildPolyline (Polyline singlePolyline) =+ " 0\n" <> "POLYLINE\n" <>+ " 8\n" <> "0\n" <>+ " 6\n" <> "CONTINUOUS\n" <>+ " 66\n" <> "1\n" <>+ " 62\n" <> buildInt (length singlePolyline) <> "\n" <>+ " 10\n" <> "0.0\n" <>+ " 20\n" <> "0.0\n" <>+ " 30\n" <> "0.0000\n" <>+ foldMap buildVertex singlePolyline <>+ " 0\n" <> "SEQEND\n"+ buildVertex :: ℝ2 -> Builder+ buildVertex (x1,y1) =+ " 0\n" <>"VERTEX\n" <>+ " 8\n" <>"0\n" <>+ " 10\n" <> buildTruncFloat x1 <> "\n" <>+ " 20\n" <> buildTruncFloat y1 <> "\n"+ (dxfxmin, dxfxmax, dxfymin, dxfymax) = (minimum xs, maximum xs, minimum ys, maximum ys)+ (xs, ys) = unzip $ foldMap pair plines+ pair :: Polyline -> [ℝ2]+ pair (Polyline x) = x++orderPolylines :: [Polyline] -> [Polyline]+orderPolylines =+ fmap snd . sortBy (\(a,_) (b, _) -> compare a b) . fmap (\x -> (polylineRadius x, x))+ where+ polylineRadius :: Polyline -> ℝ+ polylineRadius polyline' = max (xmax' - xmin') (ymax' - ymin')+ where+ ((xmin', xmax'), (ymin', ymax')) = polylineRadius' [polyline']+ polylineRadius' :: [Polyline] -> (ℝ2, ℝ2)+ polylineRadius' lines = (maxMinList xs,maxMinList ys)+ where+ (xs,ys) = unzip $ foldMap pair lines+ pair (Polyline a) = a+ maxMinList :: [ℝ] -> (ℝ,ℝ)+ maxMinList (x:others) = foldl (\(l,h) y -> (min l y, max h y)) (x,x) others+ maxMinList [] = (0,0)++-- | Gcode generation for the laser cutter in HackLab. Complies with https://ws680.nist.gov/publication/get_pdf.cfm?pub_id=823374+-- FIXME: parameters would be nice. hacklabLaserGCode :: [Polyline] -> Text-hacklabLaserGCode polylines = toLazyText $ gcodeHeader <> mconcat (map interpretPolyline orderedPolylines) <> gcodeFooter+hacklabLaserGCode polylines = toLazyText $ gcodeHeader <> foldMap interpretPolyline (orderPolylines polylines) <> gcodeFooter where- orderedPolylines :: [Polyline]- orderedPolylines =- map snd- . sortBy (\(a,_) (b, _) -> compare a b)- . map (\x -> (polylineRadius x, x))- $ polylines- polylineRadius :: [ℝ2] -> ℝ- polylineRadius [] = 0- polylineRadius polyline' = max (xmax' - xmin') (ymax' - ymin') where- ((xmin', xmax'), (ymin', ymax')) = polylineRadius' polyline'- 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))- where ((xmin, xmax), (ymin, ymax)) = polylineRadius' ps gcodeHeader :: Builder- gcodeHeader = mconcat [- "(generated by ImplicitCAD, based of hacklab wiki example)\n"- ,"M63 P0 (laser off)\n"- ,"G0 Z0.002 (laser off)\n"- ,"G21 (units=mm)\n"- ,"F400 (set feedrate)\n"- ,"M3 S1 (enable laser)\n\n"]+ gcodeHeader = "(generated by ImplicitCAD, based of hacklab wiki example)\n"+ <> "M63 P0 (laser off)\n"+ <> "G0 Z0.002 (laser off)\n"+ <> "G21 (units=mm)\n"+ <> "F400 (set feedrate)\n"+ <> "M3 S1 (enable laser)\n\n" gcodeFooter :: Builder- gcodeFooter = mconcat [- "M5 (disable laser)\n"- ,"G00 X0.0 Y0.0 (move to 0)\n"- ,"M2 (end)"]+ gcodeFooter = "M5 (disable laser)\n"+ <> "G00 X0.0 Y0.0 (move to 0)\n"+ <> "M2 (end)" gcodeXY :: ℝ2 -> Builder- gcodeXY (x,y) = mconcat ["X", buildTruncFloat x, " Y", buildTruncFloat y]- interpretPolyline (start:others) = mconcat [- "G00 ", gcodeXY start- ,"\nM62 P0 (laser on)\n"- ,mconcat [ "G01 " <> gcodeXY point <> "\n" | point <- others]- ,"M63 P0 (laser off)\n\n"- ]- interpretPolyline [] = mempty + gcodeXY (x,y) = "X" <> buildTruncFloat x <> " Y" <> buildTruncFloat y+ interpretPolyline :: Polyline -> Builder+ interpretPolyline (Polyline (start:others)) =+ "G00 " <> gcodeXY start+ <> "\nM62 P0 (laser on)\n"+ <> fold [ "G01 " <> gcodeXY point <> "\n" | point <- others]+ <> "M63 P0 (laser off)\n\n"+ interpretPolyline (Polyline []) = mempty
Graphics/Implicit/Export/RayTrace.hs view
@@ -2,66 +2,69 @@ -- Copyright 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}+module Graphics.Implicit.Export.RayTrace( Color(Color), average, Camera(Camera), Light(Light), Scene(Scene), traceRay, cameraRay) where --- FIXME: why are these needed?-{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts #-}+import Prelude(Show, RealFrac, Maybe(Just, Nothing), Bool(False, True), (-), (.), ($), (*), (/), min, fromInteger, max, round, fromIntegral, unzip, fmap, length, sum, maximum, minimum, (>), (+), (<), (==), pred, flip, not, abs, floor, toRational, otherwise, pure) -module Graphics.Implicit.Export.RayTrace( dynamicImage, Color, average, Camera(Camera), Light(Light), Scene(Scene), traceRay, cameraRay) where+-- Our number system, and the definition of a 3D object.+import Graphics.Implicit.Definitions (ℝ, Fastℕ, ℝ2, ℝ3, (⋅), Obj3) -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 Codec.Picture (Pixel8) -import Graphics.Implicit.Definitions (ℝ, ℕ, ℝ2, ℝ3, (⋅), Obj3)-import Codec.Picture (Pixel8, Image, DynamicImage(ImageRGBA8), PixelRGBA8(PixelRGBA8))-import Control.Monad (guard, return)+import Control.Monad (guard)+ import Control.Arrow ((***))+ import Data.VectorSpace (Scalar, magnitude, (^+^), (*^), normalized, (^-^), InnerSpace)+ import Data.Cross (cross3) +default (Fastℕ, ℝ)+ -- Definitions data Camera = Camera ℝ3 ℝ3 ℝ3 ℝ deriving Show +-- | A ray. A point, and a normal pointing in the direction the ray is going. data Ray = Ray ℝ3 ℝ3 deriving Show -data Light = Light ℝ3 ℝ- deriving Show- data Scene = Scene Obj3 Color [Light] Color -type Color = PixelRGBA8--color :: Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8-color = PixelRGBA8+-- | A light source. source point, and intensity.+data Light = Light ℝ3 ℝ+ deriving Show -dynamicImage :: Image PixelRGBA8 -> DynamicImage-dynamicImage = ImageRGBA8+-- | A colour. Red Green Blue and Alpha components.+data Color = Color Pixel8 Pixel8 Pixel8 Pixel8 -- Math +-- | The distance traveled by a line segment from the first point to the second point. vectorDistance :: ℝ3 -> ℝ3 -> Scalar ℝ3 vectorDistance a b = magnitude (b-a) -colorMult :: Pixel8 -> PixelRGBA8 -> PixelRGBA8-s `colorMult` (PixelRGBA8 a b c d) = color (s `mult` a) (s `mult` b) (s `mult` c) d+-- | Multiply a colour by an intensity.+colorMult :: Pixel8 -> Color -> Color+s `colorMult` (Color a b c d) = Color (s `mult` a) (s `mult` b) (s `mult` c) d where bound :: RealFrac a => a -> a- bound = max 0 . min 254+ bound = max 0 . min 255 mult :: Pixel8 -> Pixel8 -> Pixel8 mult x y = round . bound . toRational $ x * y +-- | Average a set of colours. average :: [Color] -> Color-average l = - let - ((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 :: ℝ+average l =+ let+ ((rs, gs), (bs, as)) = (unzip *** unzip) . unzip $ fmap+ (\(Color r g b a) -> ((fromIntegral r, fromIntegral g), (fromIntegral b, fromIntegral a)))+ l :: (([ℝ], [ℝ]), ([ℝ], [ℝ]))+ n :: ℝ+ n = fromIntegral $ length l (r', g', b', a') = (sum rs/n, sum gs/n, sum bs/n, sum as/n)- in PixelRGBA8+ in Color (fromInteger . round $ r') (fromInteger . round $ g') (fromInteger . round $ b') (fromInteger . round $ a') -- Ray Utilities@@ -75,6 +78,7 @@ in Ray p' n +-- | Create a ray from two points. rayFromTo :: ℝ3 -> ℝ3 -> Ray rayFromTo p1 p2 = Ray p1 (normalized $ p2 ^-^ p1) @@ -92,18 +96,17 @@ (lower, upper) -- Intersection--+-- FIXME: magic numbers. intersection :: Ray -> ((ℝ,ℝ), ℝ) -> ℝ -> Obj3 -> Maybe ℝ3 intersection r@(Ray p v) ((a, aval),b) res obj = let- step | aval/(4::ℝ) > res = res- | aval/(2::ℝ) > res = res/(2 :: ℝ)- | otherwise = 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- then + then let a'' = refine (a,a') (\s -> obj (p ^+^ s*^v)) in Just (p ^+^ a''*^v) else if a' < b@@ -111,18 +114,18 @@ else Nothing refine :: ℝ2 -> (ℝ -> ℝ) -> ℝ-refine (a, b) obj = +refine (a, b) obj = let (aval, bval) = (obj a, obj b) in if bval < aval then refine' 10 (a, b) (aval, bval) obj else refine' 10 (b, a) (aval, bval) obj -refine' :: ℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ+refine' :: Fastℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ refine' 0 (a, _) _ _ = a-refine' n (a, b) (aval, bval) obj = +refine' n (a, b) (aval, bval) obj = let- mid = (a+b)/(2::ℝ)+ mid = (a+b)/2 midval = obj mid in if midval == 0@@ -137,7 +140,7 @@ Just _ -> True -- Trace-+-- FIXME: magic numbers. traceRay :: Ray -> ℝ -> (ℝ3, ℝ3) -> Scene -> Color traceRay ray@(Ray cameraP cameraV) step box (Scene obj objColor lights defaultColor) = let@@ -156,17 +159,17 @@ deriv = (dirDeriv (1,0,0), dirDeriv (0,1,0), dirDeriv (0,0,1)) normal = normalized deriv unitV = normalized v'- proj :: forall v. InnerSpace v => v -> v -> v+ proj :: InnerSpace v => v -> v -> v proj a' b' = (a'⋅b')*^b' dist = vectorDistance p lightPos illumination = max 0 (normal ⋅ unitV) * lightIntensity * (25 /dist)- rV = + rV = let normalComponent = proj v' normal parComponent = v' - normalComponent in- normalComponent - parComponent - return $ illumination*(3 + 0.3*abs(rV ⋅ cameraV)*abs(rV ⋅ cameraV))+ normalComponent - parComponent+ pure $ illumination*(3 + 0.3*abs(rV ⋅ cameraV)*abs(rV ⋅ cameraV)) ) Nothing -> defaultColor
Graphics/Implicit/Export/Render.hs view
@@ -2,21 +2,20 @@ -- Copyright 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}- -- Allow us to use the tearser parallel list comprehension syntax, to avoid having to call zip in the complicated comprehensions below. {-# LANGUAGE ParallelListComp #-} -- 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, (+), (*), max, div, tail, map, concat, realToFrac, (==), (||), filter, not, reverse, (.), Eq, concatMap)+import Prelude(ceiling, ($), (+), (*), max, div, tail, fmap, reverse, (.), foldMap, min, Int, (<>), (<$>)) -import Graphics.Implicit.Definitions (ℝ, ℕ, ℝ2, ℝ3, TriangleMesh, Obj2, Obj3, Triangle, Polyline, (⋯/))+import Graphics.Implicit.Definitions (ℝ, ℕ, Fastℕ, ℝ2, ℝ3, TriangleMesh, Obj2, Obj3, Polyline(Polyline), (⋯/), both, allthree, fromℕtoℝ, fromℕ) import Data.VectorSpace ((^-^)) +import Data.Foldable(fold)+ -- Here's the plan for rendering a cube (the 2D case is trivial): -- (1) We calculate midpoints using interpolate.@@ -45,8 +44,6 @@ -- 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)- -- The actual code is just a bunch of ugly argument passing. -- Utility functions can be found at the end. @@ -67,13 +64,11 @@ -- 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)+-- Set the default types for the numbers in this file.+default (ℕ, Fastℕ, ℝ) --- FIXME: res should be ℝ3, not ℝ.-getMesh :: ℝ3 -> ℝ3 -> ℝ -> Obj3 -> TriangleMesh-getMesh p1@(x1,y1,z1) p2 res obj =+getMesh :: ℝ3 -> ℝ3 -> ℝ3 -> Obj3 -> TriangleMesh+getMesh p1@(x1,y1,z1) p2 res@(xres,yres,zres) obj = let -- How much space are we rendering? d = p2 ^-^ p1@@ -82,98 +77,89 @@ nx :: ℕ ny :: ℕ nz :: ℕ- (nx,ny,nz) = ceiling `allthree` ( d ⋯/ (res,res,res))+ (nx,ny,nz) = ceiling `allthree` ( d ⋯/ res) -- How big are the steps?- (rx,ry,rz) = d ⋯/ (fromIntegral `allthree` (nx,ny,nz))+ (rx,ry,rz) = d ⋯/ (fromℕtoℝ `allthree` (nx,ny,nz)) -- The positions we're rendering.- pXs = [ x1 + rx*n | n <- [0.. fromIntegral nx] ]- pYs = [ y1 + ry*n | n <- [0.. fromIntegral ny] ]- pZs = [ z1 + rz*n | n <- [0.. fromIntegral nz] ]+ pXs = [ x1 + rx*fromℕtoℝ n | n <- [0.. nx] ]+ pYs = [ y1 + ry*fromℕtoℝ n | n <- [0.. ny] ]+ pZs = [ z1 + rz*fromℕtoℝ n | n <- [0.. nz] ] - par3DList :: forall t. NFData t => ℕ -> ℕ -> ℕ -> ((ℕ -> ℝ) -> ℕ -> (ℕ -> ℝ) -> ℕ -> (ℕ -> ℝ) -> ℕ -> t) -> [[[t]]]+ -- | performance tuning.+ -- FIXME: magic number.+ forcesteps :: Int+ forcesteps=32++ -- | Perform a given function on every point in a 3D grid.+ par3DList :: ℕ -> ℕ -> ℕ -> ((ℕ -> ℝ) -> ℕ -> (ℕ -> ℝ) -> ℕ -> (ℕ -> ℝ) -> ℕ -> ℝ) -> [[[ℝ]]] par3DList lenx leny lenz f = [[[f- (\n -> x1 + rx*fromIntegral (mx+n)) mx- (\n -> y1 + ry*fromIntegral (my+n)) my- (\n -> z1 + rz*fromIntegral (mz+n)) mz+ (\n -> x1 + rx*fromℕtoℝ (mx+n)) mx+ (\n -> y1 + ry*fromℕtoℝ (my+n)) my+ (\n -> z1 + rz*fromℕtoℝ (mz+n)) mz | mx <- [0..lenx] ] | my <- [0..leny] ] | mz <- [0..lenz] ]- `using` parBuffer (max 1 . fromIntegral $ div lenz 32) rdeepseq+ `using` parBuffer (max 1 $ div (fromℕ $ lenx+leny+lenz) forcesteps) rdeepseq - -- Evaluate obj to avoid waste in mids, segs, later.+ -- | Evaluate obj to avoid waste in mids, segs, later. objV = par3DList (nx+2) (ny+2) (nz+2) $ \x _ y _ z _ -> obj (x 0, y 0, z 0) -- (1) Calculate mid points on X, Y, and Z axis in 3D space. midsZ = [[[- interpolate (z0, objX0Y0Z0) (z1', objX0Y0Z1) (appAB obj x0 y0) res- | x0 <- pXs | objX0Y0Z0 <- objY0Z0 | objX0Y0Z1 <- objY0Z1- ]| y0 <- pYs | objY0Z0 <- objZ0 | objY0Z1 <- objZ1- ]| z0 <- pZs | z1' <- tail pZs | objZ0 <- objV | objZ1 <- tail objV- ] `using` parBuffer (max 1 . fromIntegral $ div nz 32) rdeepseq+ interpolate (z0, objX0Y0Z0) (z1', objX0Y0Z1) (appABC obj x0 y0) zres+ | 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 $ div (fromℕ nz) forcesteps) 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 $ fromIntegral $ div ny 32) rdeepseq+ interpolate (y0, objX0Y0Z0) (y1', objX0Y1Z0) (appACB obj x0 z0) yres+ | x0 <- pXs | objX0Y0Z0 <- objY0Z0 | objX0Y1Z0 <- objY1Z0+ ]| y0 <- pYs | y1' <- tail pYs | objY0Z0 <- objZ0 | objY1Z0 <- tail objZ0+ ]| z0 <- pZs | objZ0 <- objV+ ] `using` parBuffer (max 1 $ div (fromℕ ny) forcesteps) rdeepseq midsX = [[[- interpolate (x0, objX0Y0Z0) (x1', objX1Y0Z0) (appBC obj y0 z0) res+ interpolate (x0, objX0Y0Z0) (x1', objX1Y0Z0) (appBCA obj y0 z0) xres | x0 <- pXs | x1' <- tail pXs | objX0Y0Z0 <- objY0Z0 | objX1Y0Z0 <- tail objY0Z0- ]| y0 <- pYs | objY0Z0 <- objZ0- ]| z0 <- pZs | objZ0 <- objV- ] `using` parBuffer (max 1 $ fromIntegral $ div nx 32) rdeepseq+ ]| y0 <- pYs | objY0Z0 <- objZ0+ ]| z0 <- pZs | objZ0 <- objV+ ] `using` parBuffer (max 1 $ div (fromℕ nx) forcesteps) rdeepseq - -- Calculate segments for each side+ -- (2) Calculate segments for each side segsZ = [[[- map2 (inj3 z0) $ getSegs (x0,y0) (x1',y1') (obj **$ z0)- (objX0Y0Z0, objX1Y0Z0, objX0Y1Z0, objX1Y1Z0)- (midA0, midA1, midB0, midB1)- |x0<-pXs|x1'<-tail pXs|midB0<-mX'' |midB1<-mX'T |midA0<-mY'' |midA1<-tail mY''- |objX0Y0Z0<-objY0Z0|objX1Y0Z0<-tail objY0Z0|objX0Y1Z0<-objY1Z0|objX1Y1Z0<-tail objY1Z0- ]|y0<-pYs|y1'<-tail pYs|mX'' <-mX' |mX'T <-tail mX'|mY'' <-mY'- |objY0Z0 <- objZ0 | objY1Z0 <- tail objZ0- ]|z0<-pZs |mX' <-midsX| mY' <-midsY- |objZ0 <- objV- ] `using` parBuffer (max 1 $ fromIntegral $ div nz 32) rdeepseq+ injZ z0 <$> getSegs (x0,y0) (x1',y1') (obj **$ z0) (objX0Y0Z0, objX1Y0Z0, objX0Y1Z0, objX1Y1Z0) (midA0, midA1, midB0, midB1)+ | x0<-pXs | x1'<-tail pXs |midB0<-mX'' | midB1<-mX'T | midA0<-mY'' | midA1<-tail mY'' | objX0Y0Z0<-objY0Z0 | objX1Y0Z0<- tail objY0Z0 | objX0Y1Z0<-objY1Z0 | objX1Y1Z0<-tail objY1Z0+ ]| y0<-pYs | y1'<-tail pYs |mX'' <-mX' | mX'T <-tail mX' | mY'' <-mY' | objY0Z0 <-objZ0 | objY1Z0 <-tail objZ0+ ]| z0<-pZs |mX' <-midsX | mY' <-midsY | objZ0 <-objV+ ] `using` parBuffer (max 1 $ div (fromℕ nz) forcesteps) rdeepseq segsY = [[[- map2 (inj2 y0) $ getSegs (x0,z0) (x1',z1') (obj *$* y0)- (objX0Y0Z0,objX1Y0Z0,objX0Y0Z1,objX1Y0Z1)- (midA0, midA1, midB0, midB1)- |x0<-pXs|x1'<-tail pXs|midB0<-mB'' |midB1<-mBT' |midA0<-mA'' |midA1<-tail mA''- |objX0Y0Z0<-objY0Z0|objX1Y0Z0<-tail objY0Z0|objX0Y0Z1<-objY0Z1|objX1Y0Z1<-tail objY0Z1- ]|y0<-pYs| mB'' <-mB' |mBT' <-mBT |mA'' <-mA'- |objY0Z0 <- objZ0 | objY0Z1 <- objZ1- ]|z0<-pZs|z1'<-tail pZs|mB' <-midsX|mBT <-tail midsX|mA' <-midsZ- |objZ0 <- objV | objZ1 <- tail objV- ] `using` parBuffer (max 1 $ fromIntegral $ div ny 32) rdeepseq+ injY y0 <$> getSegs (x0,z0) (x1',z1') (obj *$* y0) (objX0Y0Z0, objX1Y0Z0, objX0Y0Z1, objX1Y0Z1) (midA0, midA1, midB0, midB1)+ | x0<-pXs | x1'<-tail pXs | midB0<-mB'' | midB1<-mBT' | midA0<-mA'' | midA1<-tail mA'' | objX0Y0Z0<-objY0Z0 | objX1Y0Z0<-tail objY0Z0 | objX0Y0Z1<-objY0Z1 | objX1Y0Z1<-tail objY0Z1+ ]| y0<-pYs | mB'' <-mB' | mBT' <-mBT | mA'' <-mA' | objY0Z0 <-objZ0 | objY0Z1 <-objZ1+ ]| z0<-pZs | z1'<-tail pZs | mB' <-midsX | mBT <-tail midsX | mA' <-midsZ | objZ0 <-objV | objZ1 <-tail objV+ ] `using` parBuffer (max 1 $ div (fromℕ ny) forcesteps) rdeepseq segsX = [[[- map2 (inj1 x0) $ getSegs (y0,z0) (y1',z1') (obj $** x0)- (objX0Y0Z0,objX0Y1Z0,objX0Y0Z1,objX0Y1Z1)- (midA0, midA1, midB0, midB1)- |x0<-pXs| midB0<-mB'' |midB1<-mBT' |midA0<-mA'' |midA1<-mA'T- |objX0Y0Z0<-objY0Z0|objX0Y1Z0<- objY1Z0|objX0Y0Z1<-objY0Z1|objX0Y1Z1<- objY1Z1- ]|y0<-pYs|y1'<-tail pYs|mB'' <-mB' |mBT' <-mBT |mA'' <-mA' |mA'T <-tail mA'- |objY0Z0 <-objZ0 |objY1Z0 <-tail objZ0 |objY0Z1 <-objZ1 |objY1Z1 <-tail objZ1- ]|z0<-pZs|z1'<-tail pZs|mB' <-midsY|mBT <-tail midsY|mA' <-midsZ- |objZ0 <- objV | objZ1 <- tail objV- ] `using` parBuffer (max 1 $ fromIntegral $ div nx 32) rdeepseq+ injX x0 <$> getSegs (y0,z0) (y1',z1') (obj $** x0) (objX0Y0Z0, objX0Y1Z0, objX0Y0Z1, objX0Y1Z1) (midA0, midA1, midB0, midB1)+ | x0<-pXs | midB0<-mB'' | midB1<-mBT' | midA0<-mA'' | midA1<-mA'T | objX0Y0Z0<-objY0Z0 | objX0Y1Z0<-objY1Z0 | objX0Y0Z1<-objY0Z1 | objX0Y1Z1<- objY1Z1+ ]| y0<-pYs | y1'<-tail pYs | mB'' <-mB' | mBT' <-mBT | mA'' <-mA' | mA'T <-tail mA' | objY0Z0 <-objZ0 | objY1Z0 <-tail objZ0 | objY0Z1 <-objZ1 | objY1Z1 <-tail objZ1+ ]| z0<-pZs | z1'<-tail pZs | mB' <-midsY | mBT <-tail midsY | mA' <-midsZ | objZ0 <- objV | objZ1 <- tail objV+ ] `using` parBuffer (max 1 $ div (fromℕ nx) forcesteps) rdeepseq -- (3) & (4) : get and tesselate loops+ -- FIXME: hack.+ minres = xres `min` yres `min` zres sqTris = [[[- concatMap (tesselateLoop res obj) $ getLoops $ concat [- segX''',- mapR segX''T,- mapR segY''',- segY'T',- segZ''',+ foldMap (tesselateLoop minres obj) $ getLoops $ + segX''' <>+ mapR segX''T <>+ mapR segY''' <>+ segY'T' <>+ segZ''' <> mapR segZT''- ]- | segZ'''<- segZ''| segZT''<- segZT' | segY'''<- segY''| segY'T'<- segY'T | segX'''<- segX''| segX''T<- tail segX''@@ -183,152 +169,115 @@ | segX'' <- segX' ]| segZ' <- segsZ | segZT <- tail segsZ- | segY' <- segsY- | segX' <- segsX- ] `using` parBuffer (max 1 $ fromIntegral $ div nz 32) rdeepseq+ | segY' <- segsY+ | segX' <- segsX+ ] `using` parBuffer (max 1 $ div (fromℕ $ nx+ny+nz) forcesteps) rdeepseq 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.-cleanupTris :: TriangleMesh -> TriangleMesh-cleanupTris tris =- let- toFloat :: ℝ -> Float- toFloat = realToFrac- floatPoint :: (ℝ, ℝ, ℝ) -> (Float, Float, Float)- floatPoint (a,b,c) = (toFloat a, toFloat b, toFloat c)- isDegenerateTriFloat :: Eq t => (t,t,t) -> Bool- isDegenerateTriFloat (a,b,c) = (a == b) || (b == c) || (a == c)- isDegenerateTri :: Triangle -> Bool- 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)+ mergedSquareTris . fold . fold $ fold sqTris --- getContour gets a polyline describing the edge of a 2D object.-getContour :: ℝ2 -> ℝ2 -> ℝ -> Obj2 -> [Polyline]-getContour p1@(x1, y1) p2 res obj =+-- | getContour gets a polyline describing the edge of a 2D object.+getContour :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [Polyline]+getContour p1@(x1, y1) p2 res@(xres,yres) obj = let- -- the size of the region we're being asked to search.+ -- | The size of the region we're being asked to search. d = p2 ^-^ p1 - -- How many steps will we take on each axis?+ -- | How many steps will we take on each axis? nx :: ℕ ny :: ℕ- (nx,ny) = (ceiling) `both` (d ⋯/ (res,res))+ (nx,ny) = ceiling `both` (d ⋯/ res) - -- How big are the steps?- (rx,ry) = d ⋯/ (fromIntegral `both` (nx,ny))+ -- | How big are the steps?+ (rx,ry) = d ⋯/ (fromℕtoℝ `both` (nx,ny)) - -- the points inside of the region.- pYs = [ y1 + ry*(fromIntegral p) | p <- [0.. ny] ]- pXs = [ x1 + rx*(fromIntegral p) | p <- [0.. nx] ]+ -- The points inside of the region.+ pYs = [ y1 + ry*fromℕtoℝ p | p <- [0.. ny] ]+ pXs = [ x1 + rx*fromℕtoℝ p | p <- [0.. nx] ] - par2DList :: forall t. NFData t => ℕ -> ℕ -> ((ℕ -> ℝ) -> ℕ -> (ℕ -> ℝ) -> ℕ -> t) -> [[t]]+ -- | Performance tuning.+ -- FIXME: magic number.+ forcesteps :: Int+ forcesteps=32++ par2DList :: ℕ -> ℕ -> ((ℕ -> ℝ) -> ℕ -> (ℕ -> ℝ) -> ℕ -> ℝ) -> [[ℝ]] par2DList lenx leny f = [[ f- (\n -> x1 + rx*fromIntegral (mx+n)) mx- (\n -> y1 + ry*fromIntegral (my+n)) my- | mx <- [0..lenx] ] | my <- [0..leny] ]- `using` parBuffer (max 1 . fromIntegral $ div leny 32) rdeepseq--- -- Evaluate obj to avoid waste in mids, segs, later.+ (\n -> x1 + rx*fromℕtoℝ (mx+n)) mx+ (\n -> y1 + ry*fromℕtoℝ (my+n)) my+ | mx <- [0..lenx]+ ] | my <- [0..leny]+ ] `using` parBuffer (max 1 $ div (fromℕ $ lenx+leny) forcesteps) rdeepseq + -- | Fully evaluate obj to avoid waste in mids, segs, later. objV = par2DList (nx+2) (ny+2) $ \x _ y _ -> obj (x 0, y 0) - -- (1) Calculate mid points on X, and Y axis in 2D space.-+ -- | Calculate mid points on X, and Y axis in 2D space. midsY = [[- interpolate (y0, objX0Y0) (y1', objX0Y1) (obj $* x0) res- | x0 <- pXs | objX0Y0 <- objY0 | objX0Y1 <- objY1+ interpolate (y0, objX0Y0) (y1', objX0Y1) (obj $* x0) yres+ | x0 <- pXs | objX0Y0 <- objY0 | objX0Y1 <- objY1 ]| y0 <- pYs | y1' <- tail pYs | objY0 <- objV | objY1 <- tail objV- ] `using` parBuffer (max 1 . fromIntegral $ div ny 32) rdeepseq+ ] `using` parBuffer (max 1 $ div (fromℕ ny) forcesteps) rdeepseq midsX = [[- interpolate (x0, objX0Y0) (x1', objX1Y0) (obj *$ y0) res+ interpolate (x0, objX0Y0) (x1', objX1Y0) (obj *$ y0) xres | x0 <- pXs | x1' <- tail pXs | objX0Y0 <- objY0 | objX1Y0 <- tail objY0- ]| y0 <- pYs | objY0 <- objV- ] `using` parBuffer (max 1 . fromIntegral $ div nx 32) rdeepseq-- -- Calculate segments for each side+ ]| y0 <- pYs | objY0 <- objV+ ] `using` parBuffer (max 1 $ div (fromℕ nx) forcesteps) rdeepseq + -- | Calculate segments for each side segs = [[- getSegs (x0,y0) (x1',y1') obj- (objX0Y0, objX1Y0, objX0Y1, objX1Y1)- (midA0, midA1, midB0, midB1)- |x0<-pXs|x1'<-tail pXs|midB0<-mX'' |midB1<-mX'T |midA0<-mY'' |midA1<-tail mY''- |objX0Y0<-objY0|objX1Y0<-tail objY0|objX0Y1<-objY1|objX1Y1<-tail objY1- ]|y0<-pYs|y1'<-tail pYs|mX'' <-midsX|mX'T <-tail midsX|mY'' <-midsY- |objY0 <- objV | objY1 <- tail objV- ] `using` parBuffer (max 1 . fromIntegral $ div ny 32) rdeepseq-+ getSegs (x0,y0) (x1',y1') obj (objX0Y0, objX1Y0, objX0Y1, objX1Y1) (midA0, midA1, midB0, midB1)+ | x0<-pXs | x1'<-tail pXs |midB0<-mX'' | midB1<-mX'T | midA0<-mY'' | midA1<-tail mY'' | objX0Y0<-objY0 | objX1Y0<-tail objY0 | objX0Y1<-objY1 | objX1Y1<-tail objY1+ ]| y0<-pYs | y1'<-tail pYs |mX'' <-midsX | mX'T <-tail midsX | mY'' <-midsY | objY0 <- objV | objY1 <- tail objV+ ] `using` parBuffer (max 1 $ div (fromℕ $ nx+ny) forcesteps) rdeepseq in- cleanLoopsFromSegs . concat $ concat segs -- (5) merge squares, etc-+ -- | Merge squares, etc+ cleanLoopsFromSegs . fold $ fold segs+ -- utility functions--inj1 :: forall t t1 t2. t -> (t1, t2) -> (t, t1, t2)-inj1 a (b,c) = (a,b,c)-inj2 :: forall t t1 t2. t1 -> (t, t2) -> (t, t1, t2)-inj2 b (a,c) = (a,b,c)-inj3 :: forall t t1 t2. t2 -> (t, t1) -> (t, t1, t2)-inj3 c (a,b) = (a,b,c)+ +injX :: ℝ -> Polyline -> [ℝ3]+injX a (Polyline xs) = fmap (prepend a) xs+prepend :: ℝ -> ℝ2 -> ℝ3+prepend a (b,c) = (a,b,c)+injY :: ℝ -> Polyline -> [ℝ3]+injY a (Polyline xs) = fmap (insert a) xs+insert :: ℝ -> ℝ2 -> ℝ3+insert b (a,c) = (a,b,c)+injZ :: ℝ -> Polyline -> [ℝ3]+injZ a (Polyline xs) = fmap (postfix a) xs+postfix :: ℝ -> ℝ2 -> ℝ3+postfix c (a,b) = (a,b,c) -($**) :: forall t t1 t2 t3. ((t1, t2, t3) -> t) -> t1 -> (t2, t3) -> t+($**) :: Obj3 -> ℝ -> ℝ2 -> ℝ+f $** a = \(b,c) -> f (a,b,c) infixr 0 $**-(*$*) :: forall t t1 t2 t3. ((t1, t2, t3) -> t) -> t2 -> (t1, t3) -> t++(*$*) :: Obj3 -> ℝ -> ℝ2 -> ℝ+f *$* b = \(a,c) -> f (a,b,c) infixr 0 *$*-(**$) :: forall t t1 t2 t3. ((t1, t2, t3) -> t) -> t3 -> (t1, t2) -> t++(**$) :: Obj3 -> ℝ -> ℝ2 -> ℝ+f **$ c = \(a,b) -> f (a,b,c) infixr 0 **$ -($*) :: forall t t1 t2. ((t1, t2) -> t) -> t1 -> t2 -> t+($*) :: Obj2 -> ℝ -> ℝ -> ℝ+f $* a = \b -> f (a,b) infixr 0 $*-(*$) :: forall t t1 t2. ((t1, t2) -> t) -> t2 -> t1 -> t-infixr 0 *$ -f $* a = \b -> f (a,b)+(*$) :: Obj2 -> ℝ -> ℝ -> ℝ f *$ b = \a -> f (a,b)-f $** a = \(b,c) -> f (a,b,c)-f *$* b = \(a,c) -> f (a,b,c)-f **$ c = \(a,b) -> f (a,b,c)--appAB :: forall t t1 t2 t3. ((t1, t2, t3) -> t) -> t1 -> t2 -> t3 -> t-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)-appAC :: forall t t1 t2 t3. ((t1, t2, t3) -> t) -> t1 -> t3 -> t2 -> t-appAC f a c b = f (a,b,c)--map2 :: forall a b. (a -> b) -> [[a]] -> [[b]]-map2 f = map (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--{--lagzip a = zip a (tail a)-tupzip (a,b) = zip a b-tupzip3 (a,b,c) = zip3 a b c--zipD2 a b = map tupzip $ zip a b-zipD3 a b = map (map tupzip) . map tupzip $ zip a b--zip3D3 a b c = map (map tupzip3) . map tupzip3 $ zip3 a b c+infixr 0 *$ -lag3s02 = map (map tupzip) . map tupzip . lagzip-lag3s12 = map (map tupzip) . map lagzip-lag3s22 = map (map lagzip)+appABC :: Obj3 -> ℝ -> ℝ -> ℝ -> ℝ+appABC f a b c = f (a,b,c)+appBCA :: Obj3 -> ℝ -> ℝ -> ℝ -> ℝ+appBCA f b c a = f (a,b,c)+appACB :: Obj3 -> ℝ -> ℝ -> ℝ -> ℝ+appACB f a c b = f (a,b,c) -lag3 :: [[[a]]] -> [[[(a,a)]]]-lag3 a = zipD3 a $ map (map tail) $ map tail $ tail a+mapR :: [[ℝ3]] -> [[ℝ3]]+mapR = fmap reverse -for3 = flip (map . map . map)--}
Graphics/Implicit/Export/Render/Definitions.hs view
@@ -4,17 +4,15 @@ -- We want a type that can represent squares/quads and triangles. module Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq)) where -import Prelude()-+-- Points/Numbers, and the concept of an array of triangles. import Graphics.Implicit.Definitions(ℝ, ℝ2, ℝ3, TriangleMesh) +-- So we can use Parallel on this type. import Control.DeepSeq (NFData, rnf) data TriSquare = Sq (ℝ3,ℝ3,ℝ3) ℝ ℝ2 ℝ2 | Tris TriangleMesh---- 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
@@ -2,29 +2,30 @@ -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}- module Graphics.Implicit.Export.Render.GetLoops (getLoops) where -- Explicitly include what we want from Prelude.-import Prelude (Eq, head, last, tail, (==), Bool(False), (.), null, error, (++))+import Prelude (head, last, tail, (==), Bool(False), (.), null, error, (<>)) +-- We're working with 3D points here.+import Graphics.Implicit.Definitions (ℝ3)+ import Data.List (partition)--- The goal of getLoops is to extract loops from a list of segments. --- The input is a list of segments.--- the output a list of loops, where each loop is a list of --- segments, which each piece representing a "side".+-- | The goal of getLoops is to extract loops from a list of segments.+-- The input is a list of segments.+-- The output a list of loops, where each loop is a list of +-- segments, which each piece representing a "side". -- For example:--- Given input [[1,2],[5,1],[3,4,5]] +-- Given points [[1,2],[5,1],[3,4,5], ... ] -- notice that there is a loop 1,2,3,4,5... <repeat>--- But we give the output [ [1,2], [3,4,5], [5,1] ]+-- But we give the output [ [ [1,2], [3,4,5], [5,1] ], ... ] -- so that we have the loop, and also knowledge of how -- the list is built (the "sides" of it). -getLoops :: Eq a => [[a]] -> [[[a]]]+getLoops :: [[ℝ3]] -> [[[ℝ3]]]+getLoops a = getLoops' a [] -- We will be actually doing the loop extraction with -- getLoops'@@ -34,46 +35,36 @@ -- built. -- so we begin with the "building loop" being empty.--getLoops a = getLoops' a []--getLoops' :: Eq a => [[a]] -> [[a]] -> [[[a]]]---- If there aren't any segments,--- and the "building loop" is empty, --- we produce no loops.+getLoops' :: [[ℝ3]] -> [[ℝ3]] -> [[[ℝ3]]] +-- | If there aren't any segments, and the "building loop" is empty, produce no loops. getLoops' [] [] = [] --- If the building loop is empty,--- we stick the first segment we have onto it--- to give us something to build on.-+-- | If the building loop is empty, stick the first segment we have onto it to give us something to build on. getLoops' (x:xs) [] = getLoops' xs [x] --- A loop is finished if its start and end are the same.--- In this case, we return it and start searching for another loop.-+-- | A loop is finished if its start and end are the same.+-- Return it and start searching for another loop. getLoops' segs workingLoop | head (head workingLoop) == last (last workingLoop) = workingLoop : getLoops' segs [] -- Finally, we search for pieces that can continue the working loop, -- and stick one on if we find it. -- Otherwise... something is really screwed up.- getLoops' segs workingLoop = let- presEnd :: forall c. [[c]] -> c+ presEnd :: [[ℝ3]] -> ℝ3 presEnd = last . last connects (x:_) = x == presEnd workingLoop- connects [] = False -- Handle the empty case.+ -- Handle the empty case.+ connects [] = False -- divide our set into sequences that connect, and sequences that don't.- (possibleConts,nonConts) = partition connects segs+ (possibleConts, nonConts) = partition connects segs (next, unused) = if null possibleConts- then error "unclosed loop in paths given"- else (head possibleConts, tail possibleConts ++ nonConts)+ then error "unclosed loop in paths given"+ else (head possibleConts, tail possibleConts <> nonConts) in if null next then workingLoop : getLoops' segs []- else getLoops' unused (workingLoop ++ [next])+ else getLoops' unused (workingLoop <> [next])
Graphics/Implicit/Export/Render/GetSegs.hs view
@@ -2,11 +2,11 @@ -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE -module Graphics.Implicit.Export.Render.GetSegs (getSegs, getSegs') where+module Graphics.Implicit.Export.Render.GetSegs (getSegs) where -import Prelude(Eq, Bool(True, False), sqrt, (+), (*), (/=), map, (.), filter, ($), (<=))+import Prelude(Bool(True, False), sqrt, (+), (*), (/=), map, (.), filter, ($), (<=)) -import Graphics.Implicit.Definitions (ℝ, ℝ2, Obj2, Polyline)+import Graphics.Implicit.Definitions (ℝ, ℝ2, Obj2, Polyline(Polyline)) import Graphics.Implicit.Export.Render.RefineSegs (refine) import Graphics.Implicit.Export.Util (centroid) @@ -56,28 +56,23 @@ = midy1 -}- getSegs :: ℝ2 -> ℝ2 -> Obj2 -> (ℝ,ℝ,ℝ,ℝ) -> (ℝ,ℝ,ℝ,ℝ) -> [Polyline]-getSegs p1 p2 obj (x1y1, x2y1, x1y2, x2y2) (midx1V,midx2V,midy1V,midy2V) =+getSegs p1@(x,y) p2 obj (x1y1, x2y1, x1y2, x2y2) (midx1V,midx2V,midy1V,midy2V) = let- (x,y) = p1- -- Let's evaluate obj at a few points... c = obj (centroid [p1,p2]) (dx,dy) = p2 ^-^ p1 res = sqrt (dx*dy) - midx1 = (x, midx1V )- midx2 = (x + dx, midx2V )- midy1 = (midy1V , y )+ midx1 = (x, midx1V)+ midx2 = (x + dx, midx2V)+ midy1 = (midy1V, y ) midy2 = (midy2V, y + dy) - notPointLine :: Eq a => [a] -> Bool- notPointLine [np1, np2] = np1 /= np2- notPointLine [] = False- notPointLine [_] = False- notPointLine (_ : (_ : (_ : _))) = False+ notPointLine :: Polyline -> Bool+ notPointLine (Polyline [np1,np2]) = np1 /= np2+ notPointLine _ = False -- takes straight lines between mid points and subdivides them to -- account for sharp corners, etc.@@ -90,75 +85,32 @@ -- Empty Cases - (True, True,- True, True) -> []-- (False, False,- False, False) -> []+ (True, True, True, True) -> []+ (False, False, False, False) -> [] -- Horizontal Cases-- (True, True,- False, False) -> [[midx1, midx2]]-- (False, False,- True, True) -> [[midx2, midx1]]+ ( True, True, False, False) -> [Polyline [midx1, midx2]]+ (False, False, True, True) -> [Polyline [midx2, midx1]] -- Vertical Cases-- (False, True,- False, True) -> [[midy2, midy1]]-- (True, False,- True, False) -> [[midy1, midy2]]+ (False, True, False, True) -> [Polyline [midy2, midy1]]+ ( True, False, True, False) -> [Polyline [midy1, midy2]] -- Corner Cases-- (True, False,- False, False) -> [[midx1, midy2]]-- (False, True,- True, True) -> [[midy2, midx1]]-- (True, True,- False, True) -> [[midx1, midy1]]-- (False, False,- True, False) -> [[midy1, midx1]]-- (True, True,- True, False) -> [[midy1, midx2]]-- (False, False,- False, True) -> [[midx2, midy1]]-- (True, False,- True, True) -> [[midx2, midy2]]-- (False, True,- False, False) -> [[midy2, midx2]]+ ( True, False, False, False) -> [Polyline [midx1, midy2]]+ (False, True, True, True) -> [Polyline [midy2, midx1]]+ ( True, True, False, True) -> [Polyline [midx1, midy1]]+ (False, False, True, False) -> [Polyline [midy1, midx1]]+ ( True, True, True, False) -> [Polyline [midy1, midx2]]+ (False, False, False, True) -> [Polyline [midx2, midy1]]+ ( True, False, True, True) -> [Polyline [midx2, midy2]]+ (False, True, False, False) -> [Polyline [midy2, midx2]] -- Dual Corner Cases-- (True, False,- False, True) -> if c <= 0- then [[midx1, midy1], [midx2, midy2]]- else [[midx1, midy2], [midx2, midy1]]-- (False, True,- True, False) -> if c <= 0- then [[midy2, midx1], [midy1, midx2]]- else [[midy1, midx1], [midy2, midx2]]----- A convenience function, we don't actually care too much about-getSegs' :: (ℝ, ℝ) -> (ℝ, ℝ) -> ((ℝ, ℝ) -> ℝ) -> (ℝ, ℝ, ℝ, ℝ) -> [Polyline]-getSegs' (x1, y1) (x2, y2) obj (midx1V,midx2V,midy1V,midy2V) =- let- x1y1 = obj (x1, y1)- x2y1 = obj (x2, y1)- x1y2 = obj (x1, y2)- x2y2 = obj (x2, y2)- in- getSegs (x1, y1) (x2, y2) obj (x1y1, x2y1, x1y2, x2y2) (midx1V,midx2V,midy1V,midy2V)+ (True, False, False, True) -> if c <= 0+ then [Polyline [midx1, midy1], Polyline [midx2, midy2]]+ else [Polyline [midx1, midy2], Polyline [midx2, midy1]] + (False, True, True, False) -> if c <= 0+ then [Polyline [midy2, midx1], Polyline [midy1, midx2]]+ else [Polyline [midy1, midx1], Polyline [midy2, midx2]]
Graphics/Implicit/Export/Render/HandlePolylines.hs view
@@ -2,50 +2,50 @@ -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}--module Graphics.Implicit.Export.Render.HandlePolylines (cleanLoopsFromSegs, reducePolyline) where+module Graphics.Implicit.Export.Render.HandlePolylines (cleanLoopsFromSegs) where -import Prelude(Bool(False), Maybe(Just, Nothing), map, (.), filter, (==), last, reverse, ($), (++), tail, (-), (/), abs, (<=), (||), (&&), (*), (>), not, null, otherwise)+import Prelude(Maybe(Just, Nothing), fmap, (.), (==), last, reverse, ($), (<>), (-), (/), abs, (<=), (||), (&&), (*), (>), otherwise, error) -import Graphics.Implicit.Definitions (minℝ, Polyline, ℝ)+import Graphics.Implicit.Definitions (minℝ, Polyline(Polyline)) cleanLoopsFromSegs :: [Polyline] -> [Polyline]-cleanLoopsFromSegs =- map reducePolyline- . joinSegs- . filter polylineNotNull+cleanLoopsFromSegs = fmap reducePolyline . joinSegs +-- | Join polylines that connect. joinSegs :: [Polyline] -> [Polyline]-joinSegs [] = []-joinSegs (present:remaining) =+joinSegs (Polyline present:remaining) = let- 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 :: [Polyline] -> (Maybe Polyline, [Polyline])+ findNext (Polyline (p3:ps):segs)+ | p3 == last present = (Just (Polyline (p3:ps)), segs)+ | last ps == last present = (Just (Polyline $ reverse $ p3:ps), segs)+ | otherwise = case findNext segs of (res1,res2) -> (res1,Polyline (p3:ps):res2) findNext [] = (Nothing, [])- findNext ([]:_) = (Nothing, [])+ findNext (Polyline []:_) = (Nothing, []) in case findNext remaining of- (Nothing, _) -> present: joinSegs remaining- (Just match, others) -> joinSegs $ (present ++ tail match): others+ (Nothing, _) -> Polyline present: joinSegs remaining+ (Just (Polyline match), others) -> joinSegs $ Polyline (present <> match) : others+joinSegs [] = [] -reducePolyline :: [(ℝ, ℝ)] -> [(ℝ, ℝ)]-reducePolyline ((x1,y1):(x2,y2):(x3,y3):others)- | (x1,y1) == (x2,y2) = reducePolyline ((x2,y2):(x3,y3):others)+-- | Simplify and sort a polyline.+reducePolyline :: Polyline -> Polyline+reducePolyline (Polyline ((x1,y1):(x2,y2):(x3,y3):others))+ -- Remove sequential duplicate points.+ | (x1,y1) == (x2,y2) = reducePolyline (Polyline ((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--polylineNotNull :: [a] -> Bool-polylineNotNull (_:l) = not (null l)-polylineNotNull [] = False+ reducePolyline (Polyline ((x1,y1):(x3,y3):others))+ | otherwise = Polyline ((x1,y1) : points (reducePolyline (Polyline ((x2,y2):(x3,y3):others))))+ where+ points (Polyline pts) = pts+-- | remove sequential duplicate points.+reducePolyline (Polyline ((x1,y1):(x2,y2):others)) =+ if (x1,y1) == (x2,y2) then reducePolyline (Polyline ((x2,y2):others)) else Polyline ((x1,y1):(x2,y2):others)+-- | Return the last result.+reducePolyline l@(Polyline ((_:_))) = l+-- Should not happen.+reducePolyline (Polyline ([])) = error "empty polyline" {-cleanLoopsFromSegs = connectPolys@@ -77,10 +77,10 @@ fromSegOrPoly (Poly ps) = ps joinSegs :: [Polyline] -> [Polyline]-joinSegs = map fromSegOrPoly . joinSegs' . map toSegOrPoly+joinSegs = fmap fromSegOrPoly . joinSegs' . fmap toSegOrPoly joinSegs' :: [SegOrPoly] -> [SegOrPoly]-joinSegs' segsOrPolys = polys ++ concat (map joinAligned aligned) where+joinSegs' segsOrPolys = polys <> (foldMap joinAligned aligned) where polys = filter (not.isSeg) segsOrPolys segs = filter isSeg segsOrPolys aligned = groupWith (\(Seg basis p _) -> (basis,p)) segs@@ -106,6 +106,6 @@ in case findNext remaining of (Nothing, _) -> present:(connectPolys remaining)- (Just match, others) -> connectPolys $ (present ++ tail match): others+ (Just match, others) -> connectPolys $ (present <> tail match): others -}
Graphics/Implicit/Export/Render/HandleSquares.hs view
@@ -4,18 +4,19 @@ module Graphics.Implicit.Export.Render.HandleSquares (mergedSquareTris) where -import Prelude(concatMap, (++))+import Prelude(foldMap, (<>), ($), fmap, concat, (.), (==), compare, error) -import Graphics.Implicit.Definitions (TriangleMesh)+import Graphics.Implicit.Definitions (TriangleMesh(TriangleMesh), Triangle(Triangle))+ import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq))+ import Data.VectorSpace ((^*), (*^), (^+^)) --- Disable square merging temporarily.---import GHC.Exts (groupWith)---import Data.List (sortBy)+import GHC.Exts (groupWith)+import Data.List (sortBy) -- We want small meshes. Essential to this, is getting rid of triangles.--- We secifically mark quads in tesselation (refer to Graphics.Implicit.+-- We specifically mark quads in tesselation (refer to Graphics.Implicit. -- Export.Render.Definitions, Graphics.Implicit.Export.Render.TesselateLoops) -- So that we can try and merge them together. @@ -41,7 +42,7 @@ | | | |_________|__| - | joinXaligned (presently disabled)+ | joinXaligned v ____________ | |@@ -63,33 +64,34 @@ -- We don't need to do any work on triangles. They'll just be part of -- the list of triangles we give back. So, the triangles coming from -- triangles...- triTriangles = [tri | Tris tris <- sqTris, tri <- tris ]- --concat $ map (\(Tris a) -> a) $ filter isTris sqTris+ triTriangles :: [Triangle]+ triTriangles = [tri | Tris tris <- sqTris, tri <- unmesh tris ]+ --concat $ fmap (\(Tris a) -> a) $ filter isTris sqTris -- We actually want to work on the quads, so we find those+ squaresFromTris :: [TriSquare] 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++ unmesh (TriangleMesh m) = m++ -- Collect squares that are on the same plane.+ planeAligned = groupWith (\(Sq basis z _ _) -> (basis,z)) squaresFromTris -- For each plane: -- Select for being the same range on X and then merge them on Y -- Then vice versa.- joined = map- ( -- concat . (map joinXaligned) . groupWith (\(Sq _ _ xS _) -> xS)- concat . (map joinYaligned) . groupWith (\(Sq _ _ _ yS) -> yS)- . concat . (map joinXaligned) . groupWith (\(Sq _ _ xS _) -> xS))+ joined = fmap+ ( concat . (fmap joinXaligned) . groupWith (\(Sq _ _ xS _) -> xS)+ . concat . (fmap joinYaligned) . groupWith (\(Sq _ _ _ yS) -> yS)+ . concat . (fmap joinXaligned) . groupWith (\(Sq _ _ xS _) -> xS)) planeAligned -- Merge them back together, and we have the desired reult! finishedSquares = concat joined--}+ in -- merge them to triangles, and combine with the original triangles.- -- Disable square merging temporarily.- --triTriangles ++ concat (map squareToTri finishedSquares)- triTriangles ++ concatMap squareToTri squaresFromTris+ TriangleMesh $ triTriangles <> foldMap squareToTri finishedSquares --- And now for a bunch of helper functions that do the heavy lifting...+-- And now for the helper functions that do the heavy lifting... -{- joinXaligned :: [TriSquare] -> [TriSquare] joinXaligned quads@((Sq b z xS _):_) = let@@ -105,6 +107,7 @@ mergeAdjacent a = a in mergeAdjacent orderedQuads+joinXaligned (Tris _:_) = error "Tried to join y aligned triangles." joinXaligned [] = [] joinYaligned :: [TriSquare] -> [TriSquare]@@ -122,11 +125,11 @@ mergeAdjacent a = a in mergeAdjacent orderedQuads+joinYaligned (Tris _:_) = error "Tried to join y aligned triangles." joinYaligned [] = []--} --- Reconstruct a triangle-squareToTri :: TriSquare -> TriangleMesh+-- Deconstruct a square into two triangles.+squareToTri :: TriSquare -> [Triangle] squareToTri (Sq (b1,b2,b3) z (x1,x2) (y1,y2)) = let zV = b3 ^* z@@ -137,8 +140,8 @@ c = zV ^+^ x1V ^+^ y2V d = zV ^+^ x2V ^+^ y2V in- [(a,b,c),(c,b,d)]--squareToTri(Tris t) = t-+ [Triangle (a,b,c), Triangle (c,b,d)]+squareToTri (Tris t) = unmesh t+ where+ unmesh (TriangleMesh a) = a
Graphics/Implicit/Export/Render/Interpolate.hs view
@@ -2,15 +2,13 @@ -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}- module Graphics.Implicit.Export.Render.Interpolate (interpolate) where import Prelude((*), (>), (<), (/=), (+), (-), (/), (==), (&&), abs) -import Graphics.Implicit.Definitions (ℝ, ℕ, ℝ2)+import Graphics.Implicit.Definitions (ℝ, Fastℕ, ℝ2) +default (Fastℕ, ℝ) -- Consider a function f(x): {-@@ -121,7 +119,7 @@ -- Try the answer linear interpolation gives us... -- (n is to cut us off if recursion goes too deep)-interpolateLin :: ℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ+interpolateLin :: Fastℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ interpolateLin n (a, aval) (b, bval) obj | aval /= bval= let -- Interpolate and evaluate@@ -155,7 +153,7 @@ interpolateLin _ (a, _) _ _ = a -- Now for binary searching!-interpolateBin :: ℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ+interpolateBin :: Fastℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ -- The termination case:
Graphics/Implicit/Export/Render/RefineSegs.hs view
@@ -5,83 +5,92 @@ -- export one function, which refines polylines. module Graphics.Implicit.Export.Render.RefineSegs (refine) where -import Prelude((<), (/), (++), (*), ($), (&&), (-), (+), (.), (>), abs, tail, sqrt, (<=))+import Prelude((<), (/), (<>), (*), ($), (&&), (-), (+), (.), (>), abs, sqrt, (<=)) -import Graphics.Implicit.Definitions (ℝ, ℝ2, minℝ, ℕ, Obj2, (⋅))+import Graphics.Implicit.Definitions (ℝ, ℝ2, Polyline(Polyline), minℝ, Fastℕ, Obj2, (⋅)) import Graphics.Implicit.Export.Util (centroid) import Data.VectorSpace (normalized, magnitude, (^-^), (^*), (^+^)) --- The purpose of refine is to add detail to a polyline aproximating--- the boundary of an implicit function and to remove redundant points.---- We break this into two steps: detail and then simplify.+default (Fastℕ, ℝ) -refine :: ℝ -> Obj2 -> [ℝ2] -> [ℝ2]+-- | The purpose of refine is to add detail to a polyline aproximating+-- the boundary of an implicit function and to remove redundant points.+-- We break this into two steps: detail and then simplify.+refine :: ℝ -> Obj2 -> Polyline -> Polyline refine res obj = simplify res . detail' res obj --- we wrap detail to make it ignore very small segments, and to pass in--- an initial value for a pointer counter argument. This is detail'-+-- | We wrap detail to make it ignore very small segments, and to pass in+-- an initial value for a depth counter argument. -- FIXME: magic number.-detail' :: ℝ -> (ℝ2 -> ℝ) -> [ℝ2] -> [ℝ2]-detail' res obj [p1@(x1,y1), p2@(x2,y2)] | (x2-x1)*(x2-x1) + (y2-y1)*(y2-y1) > res*res/200 =- detail 0 res obj [p1,p2]+detail' :: ℝ -> (ℝ2 -> ℝ) -> Polyline -> Polyline+detail' res obj (Polyline [p1@(x1,y1), p2@(x2,y2)])+ | (x2-x1)*(x2-x1) + (y2-y1)*(y2-y1) > res*res/200 = detail 0 res obj $ Polyline [p1,p2] detail' _ _ a = a --- detail adds new points to a polyline to add more detail.--detail :: ℕ -> ℝ -> (ℝ2 -> ℝ) -> [ℝ2] -> [ℝ2]-detail n res obj [p1, p2] | n < 2 =+-- | detail adds new points to a polyline to add more detail.+-- FIXME: all of the magic numbers.+detail :: Fastℕ -> ℝ -> (ℝ2 -> ℝ) -> Polyline -> Polyline+detail n res obj (Polyline [p1, p2]) | n < 2 = let mid = centroid [p1,p2] midval = obj mid in if abs midval < res / 40- then [p1, p2]- else let- normal = (\(a,b) -> (b, -a)) $ normalized (p2 ^-^ p1)- derivN = -(obj (mid ^-^ (normal ^* (midval/2))) - midval) * (2/midval)- in if abs derivN > 0.5 && abs derivN < 2 && abs (midval/derivN) < 3*res- then let- mid' = mid ^-^ (normal ^* (midval / derivN))- in detail (n+1) res obj [p1, mid']- ++ tail (detail (n+1) res obj [mid', p2] )- else let- derivX = (obj (mid ^+^ (res/100, 0)) - midval)*100/res- derivY = (obj (mid ^+^ (0, res/100)) - midval)*100/res- derivNormSq = derivX*derivX + derivY*derivY- in if abs derivNormSq > 0.09 && abs derivNormSq < 4 && abs (midval/sqrt derivNormSq) < 3*res- then let- (dX, dY) = (- derivX*midval/derivNormSq, - derivY*midval/derivNormSq)- mid' = mid ^+^ (dX, dY)- midval' = obj mid'- posRatio = midval/(midval - midval')- mid'' = mid ^+^ (dX*posRatio, dY*posRatio)- in- detail (n+1) res obj [p1, mid''] ++ tail (detail (n+1) res obj [mid'', p2] )- else [p1, p2]+ then Polyline [p1, p2]+ else+ let+ normal = (\(a,b) -> (b, -a)) $ normalized (p2 ^-^ p1)+ derivN = -(obj (mid ^-^ (normal ^* (midval/2))) - midval) * (2/midval)+ in+ if abs derivN > 0.5 && abs derivN < 2 && abs (midval/derivN) < 3*res+ then+ let+ mid' = mid ^-^ (normal ^* (midval / derivN))+ in+ addPolylines (detail (n+1) res obj (Polyline [p1, mid'])) (detail (n+1) res obj ( Polyline [mid', p2] ))+ else+ let+ derivX = (obj (mid ^+^ (res/100, 0)) - midval)*100/res+ derivY = (obj (mid ^+^ (0, res/100)) - midval)*100/res+ derivNormSq = derivX*derivX + derivY*derivY+ in+ if abs derivNormSq > 0.09 && abs derivNormSq < 4 && abs (midval/sqrt derivNormSq) < 3*res+ then+ let+ (dX, dY) = (- derivX*midval/derivNormSq, - derivY*midval/derivNormSq)+ mid' = mid ^+^ (dX, dY)+ midval' = obj mid'+ posRatio = midval/(midval - midval')+ mid'' = mid ^+^ (dX*posRatio, dY*posRatio)+ in+ addPolylines (detail (n+1) res obj (Polyline [p1, mid''])) (detail (n+1) res obj ( Polyline [mid'', p2] ))+ else Polyline [p1, p2] detail _ _ _ x = x -simplify :: ℝ -> [ℝ2] -> [ℝ2]+-- FIXME: re-add simplify2 and simplify3?+simplify :: ℝ -> Polyline -> Polyline simplify _ = {-simplify3 . simplify2 res . -} simplify1 -simplify1 :: [ℝ2] -> [ℝ2]-simplify1 (a:b:c:xs) =+simplify1 :: Polyline -> Polyline+simplify1 (Polyline (a:b:c:xs)) = if abs ( ((b ^-^ a) ⋅ (c ^-^ a)) - magnitude (b ^-^ a) * magnitude (c ^-^ a) ) <= minℝ- then simplify1 (a:c:xs)- else a : simplify1 (b:c:xs)+ then simplify1 (Polyline (a:c:xs))+ else addPolylines (Polyline [a]) (simplify1 (Polyline (b:c:xs))) simplify1 a = a +addPolylines :: Polyline -> Polyline -> Polyline+addPolylines (Polyline as) (Polyline bs) = Polyline (as <> bs)+ {--simplify2 :: ℝ -> [ℝ2] -> [ℝ2]+simplify2 :: ℝ -> Polyline -> Polyline simplify2 res [a,b,c,d] = if norm (b - c) < res/10 then [a, ((b + c) / (2::ℝ)), d] else [a,b,c,d] simplify2 _ a = a -simplify3 (a:as) | length as > 5 = simplify3 $ a : half (init as) ++ [last as]+simplify3 (a:as) | length as > 5 = simplify3 $ a : half (init as) <> [last as] where half (a:b:xs) = a : half xs half a = a
Graphics/Implicit/Export/Render/TesselateLoops.hs view
@@ -4,23 +4,27 @@ module Graphics.Implicit.Export.Render.TesselateLoops (tesselateLoop) where -import Prelude(return, ($), length, (==), zip, init, tail, reverse, (<), (/), null, foldl1, (++), head, (*), abs, (>), (&&), (+), concatMap)+import Prelude(pure, ($), length, (==), zip, init, tail, reverse, (<), (/), null, foldl1, (<>), head, (*), abs, (>), (&&), (+), foldMap) -import Graphics.Implicit.Definitions (ℝ, Fastℕ, Obj3, ℝ3, TriangleMesh, (⋅))+import Graphics.Implicit.Definitions (ℝ, ℕ, Obj3, ℝ3, TriangleMesh(TriangleMesh), Triangle(Triangle)) -import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq))+import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris)) import Graphics.Implicit.Export.Util (centroid) -import Data.VectorSpace (normalized, (^-^), (^+^), magnitude, (^/), (^*))+import Data.VectorSpace ((^-^), (^+^), magnitude, (^/), (^*)) +import Data.List (genericLength)+ import Data.Cross (cross3) +-- de-compose a loop into a series of triangles or squares.+-- FIXME: res should be ℝ3. tesselateLoop :: ℝ -> Obj3 -> [[ℝ3]] -> [TriSquare] tesselateLoop _ _ [] = [] -tesselateLoop _ _ [[a,b],[_,c],[_,_]] = return $ Tris [(a,b,c)]+tesselateLoop _ _ [[a,b],[_,c],[_,_]] = [Tris $ TriangleMesh [Triangle (a,b,c)]] {-@@ -32,12 +36,12 @@ -} tesselateLoop res obj [[_,_], as@(_:_:_:_),[_,_], bs@(_:_:_:_)] | length as == length bs =- concatMap (tesselateLoop res obj)+ foldMap (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)+ foldMap (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 @@ -47,29 +51,33 @@ #__# -} --- NOTE: colah thought this was broken.+-- FIXME: this function is definately broken, resulting in floating squares. see https://github.com/colah/ImplicitCAD/issues/98 +{- tesselateLoop _ _ [[a,_],[b,_],[c,_],[d,_]] | centroid [a,c] == centroid [b,d] = let b1 = normalized $ a ^-^ b b2 = normalized $ c ^-^ b b3 = b1 `cross3` b2 in [Sq (b1,b2,b3) (a ⋅ b3) (a ⋅ b1, c ⋅ b1) (a ⋅ b2, c ⋅ b2) ]+-} {- #__# #__# | | -> | /| #__# #/_# -}-+-- | Create a pair of triangles from a quad.+-- FIXME: magic number tesselateLoop res obj [[a,_],[b,_],[c,_],[d,_]] | obj (centroid [a,c]) < res/30 =- return $ Tris [(a,b,c),(a,c,d)]+ pure $ Tris $ TriangleMesh [Triangle (a,b,c), Triangle (a,c,d)] -- Fallback case: make fans -tesselateLoop res obj pathSides = return $ Tris $+-- FIXME: magic numbers.+tesselateLoop res obj pathSides = pure $ Tris $ TriangleMesh $ let- path' = concatMap init pathSides+ path' = foldMap init pathSides (early_tris,path) = shrinkLoop 0 path' res obj in if null path then early_tris@@ -77,32 +85,33 @@ mid@(_,_,_) = centroid path midval = obj mid preNormal = foldl1 (^+^)- [ a `cross3` b | (a,b) <- zip path (tail path ++ [head path]) ]+ [ a `cross3` b | (a,b) <- zip path (tail path <> [head path]) ] preNormalNorm = magnitude preNormal normal = preNormal ^/ preNormalNorm deriv = (obj (mid ^+^ (normal ^* (res/100)) ) ^-^ midval)/res*100 mid' = mid ^-^ normal ^* (midval/deriv) in if abs midval > res/50 && preNormalNorm > 0.5 && abs deriv > 0.5 && abs (midval/deriv) < 2*res && 3*abs (obj mid') < abs midval- then early_tris ++ [(a,b,mid') | (a,b) <- zip path (tail path ++ [head path]) ]- else early_tris ++ [(a,b,mid) | (a,b) <- zip path (tail path ++ [head path]) ]+ then early_tris <> [Triangle (a,b,mid') | (a,b) <- zip path (tail path <> [head path]) ]+ else early_tris <> [Triangle (a,b,mid) | (a,b) <- zip path (tail path <> [head path]) ] -shrinkLoop :: Fastℕ -> [ℝ3] -> ℝ -> Obj3 -> (TriangleMesh, [ℝ3])+shrinkLoop :: ℕ -> [ℝ3] -> ℝ -> Obj3 -> ([Triangle], [ℝ3]) shrinkLoop _ path@[a,b,c] res obj = if abs (obj $ centroid [a,b,c]) < res/50 then- ( [(a,b,c)], [])+ ( [Triangle (a,b,c)], []) else ([], path) -shrinkLoop n path@(a:b:c:xs) res obj | n < length path =+-- FIXME: magic number.+shrinkLoop n path@(a:b:c:xs) res obj | n < genericLength path = if abs (obj (centroid [a,c])) < res/50 then let (tris,remainder) = shrinkLoop 0 (a:c:xs) res obj- in ((a,b,c):tris, remainder)+ in (Triangle (a,b,c):tris, remainder) else- shrinkLoop (n+1) (b:c:xs ++ [a]) res obj+ shrinkLoop (n+1) (b:c:xs <> [a]) res obj shrinkLoop _ path _ _ = ([],path)
− Graphics/Implicit/Export/Symbolic/CoerceSymbolic2.hs
@@ -1,29 +0,0 @@--- 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
@@ -1,35 +0,0 @@--- 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
@@ -4,12 +4,13 @@ module Graphics.Implicit.Export.Symbolic.Rebound2 (rebound2) where -import Prelude()- import Graphics.Implicit.Definitions (BoxedObj2, ℝ2) import Data.VectorSpace ((^-^), (^+^), (^/)) +-- | Slightly stretch the bounding box of an object, in order to+-- ensure that during mesh generation, there are no problems because+-- values are right at the edge. rebound2 :: BoxedObj2 -> BoxedObj2 rebound2 (obj, (a,b)) = let
Graphics/Implicit/Export/Symbolic/Rebound3.hs view
@@ -4,12 +4,13 @@ module Graphics.Implicit.Export.Symbolic.Rebound3 (rebound3) where -import Prelude()- import Graphics.Implicit.Definitions(BoxedObj3, ℝ3) import Data.VectorSpace((^-^), (^+^), (^/)) +-- | Slightly stretch the bounding box of an object, in order to+-- ensure that during mesh generation, there are no problems because+-- values are right at the edge. rebound3 :: BoxedObj3 -> BoxedObj3 rebound3 (obj, (a,b)) = let
Graphics/Implicit/Export/SymbolicFormats.hs view
@@ -5,40 +5,46 @@ -- FIXME: describe why we need this. {-# LANGUAGE OverloadedStrings #-} +-- allow us to select what package to import what module from. We don't care, but our examples do.+{-# LANGUAGE PackageImports #-}+ -- output SCAD code, AKA an implicitcad to openscad converter. module Graphics.Implicit.Export.SymbolicFormats (scad2, scad3) where -import Prelude(Maybe(Just, Nothing), Either(Left), ($), (.), (*), map, ($!), (-), (/), pi, error, (+), init, (==))+import Prelude(Either(Left, Right), ($), (*), ($!), (-), (/), pi, error, (+), (==), take, floor, (&&), const, pure, (<>), sequenceA, fmap, (<$>)) import Graphics.Implicit.Definitions(ℝ, SymbolicObj2(RectR, Circle, PolygonR, Complement2, UnionR2, DifferenceR2, IntersectR2, Translate2, Scale2, Rotate2, Outset2, Shell2, EmbedBoxedObj2), SymbolicObj3(Rect3R, Sphere, Cylinder, Complement3, UnionR3, IntersectR3, DifferenceR3, Translate3, Scale3, Rotate3, Rotate3V, Outset3, Shell3, ExtrudeR, ExtrudeRotateR, ExtrudeRM, EmbedBoxedObj3, RotateExtrude, ExtrudeOnEdgeOf))-import Graphics.Implicit.Export.TextBuilderUtils(Text, Builder, toLazyText, (<>), mconcat, fromLazyText, bf)+import Graphics.Implicit.Export.TextBuilderUtils(Text, Builder, toLazyText, fromLazyText, bf) -import Control.Monad.Reader (Reader, runReader, return, fmap, sequence, ask)+import "monads-tf" Control.Monad.Reader (Reader, runReader, ask) import Data.List (intersperse)+import Data.Function (fix)+import Data.Foldable(fold, foldMap) -scad2 :: ℝ -> SymbolicObj2 -> Text +default (ℝ)++scad2 :: ℝ -> SymbolicObj2 -> Text scad2 res obj = toLazyText $ runReader (buildS2 obj) res -scad3 :: ℝ -> SymbolicObj3 -> Text +scad3 :: ℝ -> SymbolicObj3 -> Text scad3 res obj = toLazyText $ runReader (buildS3 obj) res -- used by rotate2 and rotate3 rad2deg :: ℝ -> ℝ rad2deg r = r * (180/pi) --- Format an openscad call given that all the modified objects are in the Reader monad...-+-- | Format an openscad call given that all the modified objects are in the Reader monad... callToken :: (Text, Text) -> Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder-callToken cs name args [] = return $ name <> buildArgs cs args <> ";"+callToken cs name args [] = pure $ name <> buildArgs cs args <> ";" callToken cs name args [obj] = fmap ((name <> buildArgs cs args) <>) obj callToken cs name args objs = do- objs' <- fmap (mconcat . map (<> "\n")) $ sequence objs- return $! name <> buildArgs cs args <> "{\n" <> objs' <> "}\n"+ objs' <- foldMap (<> "\n") <$> sequenceA objs+ pure $! name <> buildArgs cs args <> "{\n" <> objs' <> "}\n" buildArgs :: (Text, Text) -> [Builder] -> Builder buildArgs _ [] = "()"-buildArgs (c1, c2) args = "(" <> fromLazyText c1 <> mconcat (intersperse "," args) <> fromLazyText c2 <> ")"+buildArgs (c1, c2) args = "(" <> fromLazyText c1 <> fold (intersperse "," args) <> fromLazyText c2 <> ")" call :: Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder call = callToken ("[", "]")@@ -46,7 +52,7 @@ callNaked :: Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder callNaked = callToken ("", "") --- First, the 3D objects.+-- | First, the 3D objects. buildS3 :: SymbolicObj3 -> Reader ℝ Builder buildS3 (Rect3R r (x1,y1,z1) (x2,y2,z2)) | r == 0 = call "translate" [bf x1, bf y1, bf z1] [@@ -63,11 +69,11 @@ buildS3 (Complement3 obj) = call "complement" [] [buildS3 obj] -buildS3 (UnionR3 r objs) | r == 0 = call "union" [] $ map buildS3 objs+buildS3 (UnionR3 r objs) | r == 0 = call "union" [] $ fmap buildS3 objs -buildS3 (IntersectR3 r objs) | r == 0 = call "intersection" [] $ map buildS3 objs+buildS3 (IntersectR3 r objs) | r == 0 = call "intersection" [] $ fmap buildS3 objs -buildS3 (DifferenceR3 r objs) | r == 0 = call "difference" [] $ map buildS3 objs+buildS3 (DifferenceR3 r objs) | r == 0 = call "difference" [] $ fmap buildS3 objs buildS3 (Translate3 (x,y,z) obj) = call "translate" [bf x, bf y, bf z] [buildS3 obj] @@ -87,14 +93,19 @@ buildS3 (ExtrudeRotateR r twist obj h) | r == 0 = callNaked "linear_extrude" ["height = " <> bf h, "twist = " <> bf twist] [buildS2 obj] -buildS3 (ExtrudeRM r (Just twist) Nothing Nothing obj (Left height)) | r == 0 = do+-- FIXME: handle scale, center.+buildS3 (ExtrudeRM r twist (Left scale) (Left translate) obj (Left height)) | r == 0 && scale == 1 && translate == (0,0) = do res <- ask+ let+ twist' = case twist of+ Left twval -> const twval+ Right twfun -> twfun call "union" [] [- call "rotate" ["0","0", bf $ twist h] [- callNaked "linear_extrude" ["height = " <> bf res, "twist = " <> bf (twist (h+res) - twist h)][+ call "rotate" ["0","0", bf $ twist' h] [+ callNaked "linear_extrude" ["height = " <> bf res, "twist = " <> bf (twist' (h+res) - twist' h)][ buildS2 obj- ] - ] | h <- init [0, res .. height]+ ]+ ] | h <- take (floor (res / height)) $ fix (\f x -> x : f (x+res)) 0 ] -- FIXME: where are RotateExtrude, ExtrudeOnEdgeOf?@@ -123,15 +134,15 @@ buildS2 (Circle r) = call "circle" [bf r] [] buildS2 (PolygonR r points) | r == 0 = call "polygon" [buildVector [x,y] | (x,y) <- points] []- where buildVector comps = "[" <> mconcat (intersperse "," $ map bf comps) <> "]"+ where buildVector comps = "[" <> fold (intersperse "," $ fmap bf comps) <> "]" buildS2 (Complement2 obj) = call "complement" [] [buildS2 obj] -buildS2 (UnionR2 r objs) | r == 0 = call "union" [] $ map buildS2 objs+buildS2 (UnionR2 r objs) | r == 0 = call "union" [] $ fmap buildS2 objs -buildS2 (DifferenceR2 r objs) | r == 0 = call "difference" [] $ map buildS2 objs+buildS2 (DifferenceR2 r objs) | r == 0 = call "difference" [] $ fmap buildS2 objs -buildS2 (IntersectR2 r objs) | r == 0 = call "intersection" [] $ map buildS2 objs+buildS2 (IntersectR2 r objs) | r == 0 = call "intersection" [] $ fmap buildS2 objs buildS2 (Translate2 (x,y) obj) = call "translate" [bf x, bf y] [buildS2 obj]
Graphics/Implicit/Export/SymbolicObj2.hs view
@@ -2,18 +2,15 @@ -- Copyright 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- FIXME: why is all of this needed?-{-# 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 (symbolicGetOrientedContour, symbolicGetContour, symbolicGetContourMesh) where -import Prelude(map, ($), (-), (/), (+), (>), (*), (.), reverse, cos, pi, sin, max, fromInteger, ceiling)+import Prelude(fmap, ($), (-), (/), (+), (>), (*), reverse, cos, pi, sin, max, ceiling, (<$>)) -import Graphics.Implicit.Definitions (ℝ, SymbolicObj2(RectR, Circle, Translate2, Scale2), Polyline, Polytri, (⋯*))+import Graphics.Implicit.Definitions (ℝ, ℝ2, Fastℕ, SymbolicObj2(RectR, Circle, Translate2, Scale2), Polyline(Polyline), Polytri(Polytri), (⋯*), fromFastℕtoℝ) import Graphics.Implicit.Export.MarchingSquaresFill (getContourMesh) @@ -21,50 +18,57 @@ import Graphics.Implicit.Export.Symbolic.Rebound2 (rebound2) -import qualified Graphics.Implicit.Export.Render as Render (getContour)+import Graphics.Implicit.Export.Render (getContour) import Data.VectorSpace ((^/), magnitude) symbolicGetOrientedContour :: ℝ -> SymbolicObj2 -> [Polyline]-symbolicGetOrientedContour res symbObj = map orient $ symbolicGetContour res symbObj+symbolicGetOrientedContour res symbObj = orient <$> symbolicGetContour res symbObj where obj = getImplicit2 symbObj+ -- FIXME: cowardly case handling. orient :: Polyline -> Polyline- orient [] = []- orient [_] = []- orient points@(x:y:_) =+ orient (Polyline points@(p1:p2:_)) = let- v = (\(a,b) -> (b, -a)) (y - x)+ v = (\(a,b) -> (b, -a)) (p2 - p1) dv = v ^/ (magnitude v / res / 0.1)- in if obj (x + dv) - obj x > 0- then points- else reverse points+ in if obj (p1 + dv) - obj p1 > 0+ then Polyline points+ else Polyline $ reverse points+ orient (Polyline []) = Polyline []+ orient (Polyline [_]) = Polyline [] -symbolicGetContour :: ℝ -> SymbolicObj2 -> [Polyline]-symbolicGetContour _ (RectR 0 (x1,y1) (x2,y2)) = [[ (x1,y1), (x2,y1), (x2,y2), (x1,y2), (x1,y1) ]]-symbolicGetContour res (Circle r) = [[ ( r*cos(2*pi*m/n), r*sin(2*pi*m/n) ) | m <- [0.. n] ]] where- n :: ℝ- n = max 5 (fromInteger . ceiling $ 2*pi*r/res)-symbolicGetContour res (Translate2 v obj) = map (map (+ v) ) $ symbolicGetContour res obj-symbolicGetContour res (Scale2 s@(a,b) obj) = map (map (⋯* s)) $ symbolicGetContour (res/sc) obj+symbolicGetContour :: ℝ -> SymbolicObj2 -> [Polyline]+symbolicGetContour _ (RectR 0 (x1,y1) (x2,y2)) = [Polyline [ (x1,y1), (x2,y1), (x2,y2), (x1,y2), (x1,y1) ]]+-- FIXME: magic number.+symbolicGetContour res (Circle r) = [Polyline [ ( r*cos(2*pi*fromFastℕtoℝ m/fromFastℕtoℝ n), r*sin(2*pi*fromFastℕtoℝ m/fromFastℕtoℝ n) ) | m <- [0.. n] ]] where+ n :: Fastℕ+ n = max 5 $ ceiling $ 2*pi*r/res+symbolicGetContour res (Translate2 v obj) = appOpPolylines (+ v) $ symbolicGetContour res obj+symbolicGetContour res (Scale2 s@(a,b) obj) = appOpPolylines (⋯* s) $ symbolicGetContour (res/sc) obj where sc = max a b symbolicGetContour res obj = case rebound2 (getImplicit2 obj, getBox2 obj) of- (obj', (a,b)) -> Render.getContour a b res obj'+ (obj', (a,b)) -> getContour a b (res,res) obj' +appOpPolylines :: (ℝ2 -> ℝ2) -> [Polyline] -> [Polyline]+appOpPolylines op = fmap (appOpPolyline op)+appOpPolyline :: (ℝ2 -> ℝ2) -> Polyline -> Polyline+appOpPolyline op (Polyline xs) = Polyline $ fmap op xs 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) ) $- symbolicGetContourMesh (res/sc) obj where sc = max a b-symbolicGetContourMesh _ (RectR 0 (x1,y1) (x2,y2)) = [((x1,y1), (x2,y1), (x2,y2)), ((x2,y2), (x1,y2), (x1,y1)) ]+symbolicGetContourMesh res (Translate2 v obj) = (\(Polytri (a,b,c)) -> Polytri (a + v, b + v, c + v)) <$>+ symbolicGetContourMesh res obj+symbolicGetContourMesh res (Scale2 s@(a,b) obj) = (\(Polytri (c,d,e)) -> Polytri (c ⋯* s, d ⋯* s, e ⋯* s)) <$>+ symbolicGetContourMesh (res/sc) obj where sc = max a b+symbolicGetContourMesh _ (RectR 0 (x1,y1) (x2,y2)) = [Polytri ((x1,y1), (x2,y1), (x2,y2)), Polytri ((x2,y2), (x1,y2), (x1,y1)) ]+-- FIXME: magic number. symbolicGetContourMesh res (Circle r) =- [ ((0,0),- (r*cos(2*pi*m/n), r*sin(2*pi*m/n)),- (r*cos(2*pi*(m+1)/n), r*sin(2*pi*(m+1)/n))+ [ Polytri ((0,0),+ (r*cos(2*pi*fromFastℕtoℝ m/fromFastℕtoℝ n), r*sin(2*pi*fromFastℕtoℝ m/fromFastℕtoℝ n)),+ (r*cos(2*pi*fromFastℕtoℝ (m+1)/fromFastℕtoℝ n), r*sin(2*pi*fromFastℕtoℝ (m+1)/fromFastℕtoℝ n)) )| m <- [0.. n-1] ] where- n :: ℝ- n = max 5 (fromInteger . ceiling $ 2*pi*r/res)+ n :: Fastℕ+ n = max 5 $ 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
@@ -2,20 +2,14 @@ -- Copyright 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}---- FIXME: why are these needed?-{-# 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, (++), concatMap)+import Prelude(fmap, zip, length, filter, (>), ($), null, (<>), foldMap, (.)) -import Graphics.Implicit.Definitions (ℝ, ℝ3, SymbolicObj3(UnionR3))+import Graphics.Implicit.Definitions (ℝ, ℝ3, SymbolicObj3(UnionR3), Triangle, TriangleMesh(TriangleMesh)) import Graphics.Implicit.Export.Render (getMesh) import Graphics.Implicit.ObjectUtil (getBox3, getImplicit3) import Graphics.Implicit.MathUtil(box3sWithin)@@ -23,12 +17,12 @@ import Control.Arrow(first, second) -symbolicGetMesh :: ℝ -> SymbolicObj3 -> [(ℝ3, ℝ3, ℝ3)]+symbolicGetMesh :: ℝ -> SymbolicObj3 -> TriangleMesh {-- -- A translated objects mesh is its mesh translated. symbolicGetMesh res (Translate3 v obj) = - map (\(a,b,c) -> (a S.+ v, b S.+ v, c S.+ v) ) (symbolicGetMesh res obj)+ fmap (\(a,b,c) -> (a S.+ v, b S.+ v, c S.+ v) ) (symbolicGetMesh res obj) -- A scaled objects mesh is its mesh scaled symbolicGetMesh res (Scale3 s obj) =@@ -37,7 +31,7 @@ mesh = symbolicGetMesh res obj scaleTriangle :: (ℝ3, ℝ3, ℝ3) -> (ℝ3, ℝ3, ℝ3) scaleTriangle (a,b,c) = (s S.⋯* a, s S.⋯* b, s S.⋯* c)- in map scaleTriangle mesh+ in fmap scaleTriangle mesh -- A couple triangles make a cube... symbolicGetMesh _ (Rect3R 0 (x1,y1,z1) (x2,y2,z2)) = @@ -46,14 +40,14 @@ rsquare a b c d = [(c,b,a),(c,a,d)] in rsquare (x1,y1,z1) (x2,y1,z1) (x2,y2,z1) (x1,y2,z1)- ++ square (x1,y1,z2) (x2,y1,z2) (x2,y2,z2) (x1,y2,z2)- ++ square (x1,y1,z1) (x2,y1,z1) (x2,y1,z2) (x1,y1,z2)- ++ rsquare (x1,y2,z1) (x2,y2,z1) (x2,y2,z2) (x1,y2,z2)- ++ square (x1,y1,z1) (x1,y1,z2) (x1,y2,z2) (x1,y2,z1)- ++ rsquare (x2,y1,z1) (x2,y1,z2) (x2,y2,z2) (x2,y2,z1)+ <> square (x1,y1,z2) (x2,y1,z2) (x2,y2,z2) (x1,y2,z2)+ <> square (x1,y1,z1) (x2,y1,z1) (x2,y1,z2) (x1,y1,z2)+ <> rsquare (x1,y2,z1) (x2,y2,z1) (x2,y2,z2) (x1,y2,z2)+ <> square (x1,y1,z1) (x1,y1,z2) (x1,y2,z2) (x1,y2,z1)+ <> rsquare (x2,y1,z1) (x2,y1,z2) (x2,y2,z2) (x2,y2,z1) -- Use spherical coordinates to create an easy tesselation of a sphere-symbolicGetMesh res (Sphere r) = half1 ++ half2+symbolicGetMesh res (Sphere r) = half1 <> half2 where -- Convenience functions for mesh generation square a b c d = [(a,b,c),(d,a,c)]@@ -66,9 +60,9 @@ -- Function placing steps on sphere f n' m' = spherical (2*pi*n'/n) (pi*m'/m) -- Mesh in two pieces..- half1 = concat [ square (f m1 m2) (f (m1+1) m2) (f (m1+1) (m2+1)) (f m1 (m2+1)) + half1 = fold [ square (f m1 m2) (f (m1+1) m2) (f (m1+1) (m2+1)) (f m1 (m2+1)) | m1 <- [0.. m-1], m2 <- [0.. m-1] ]- half2 = concat [ rsquare (f m1 m2) (f (m1+1) m2) (f (m1+1) (m2+1)) (f m1 (m2+1)) + half2 = fold [ rsquare (f m1 m2) (f (m1+1) m2) (f (m1+1) (m2+1)) (f m1 (m2+1)) | m1 <- [m.. n-1], m2 <- [0.. m-1] ] {-symbolicGetMesh res (UnionR3 r [ExtrudeR ra obja ha, ExtrudeR rb objb hb]) @@ -105,21 +99,21 @@ [((x1,y1,r-dh x1 y1), (x2,y2,r-dh x2 y2), (x2,y2,h-r+dh x2 y2)), ((x1,y1,r-dh x1 y1), (x2,y2,h-r+dh x2 y2), (x1,y1,h-r+dh x1 y1)) ] -- Get a contour polyline for obj2, turn it into a list of segments- segs = concat $ map segify $ symbolicGetOrientedContour res obj2+ segs = foldMap segify $ symbolicGetOrientedContour res obj2 -- Create sides for the main body of our object = segs × (r,h-r)- side_tris = concat $ map (\(a,b) -> segToSide a b) segs+ side_tris = foldMap (\(a,b) -> segToSide a b) segs -- Triangles that fill the contour. Make sure the mesh is at least (res/5) fine. -- --res/5 because xyres won't always match up with normal res and we need to compensate. fill_tris = {-divideMeshTo (res/5) $-} symbolicGetContourMesh res obj2 -- The bottom. Use dh to determine the z coordinates- bottom_tris = map flipTri $ [((a1,a2,r-dh a1 a2), (b1,b2,r - dh b1 b2), (c1,c2,r - dh c1 c2)) + bottom_tris = fmap flipTri $ [((a1,a2,r-dh a1 a2), (b1,b2,r - dh b1 b2), (c1,c2,r - dh c1 c2)) | ((a1,a2),(b1,b2),(c1,c2)) <- fill_tris] -- Same idea at the top. top_tris = [((a1,a2,h-r+dh a1 a2), (b1,b2,h-r+dh b1 b2), (c1,c2,h-r+dh c1 c2)) | ((a1,a2),(b1,b2),(c1,c2)) <- fill_tris] in -- Merge them all together! :)- side_tris ++ bottom_tris ++ top_tris + side_tris <> bottom_tris <> top_tris symbolicGetMesh res (ExtrudeRM r twist scale translate obj2 h) = @@ -166,19 +160,19 @@ [((x1,y1,la1), (x2,y2,la2), (x2,y2,lb2)), ((x1,y1,la1), (x2,y2,lb2), (x1,y1,lb1)) ] -- Get a contour polyline for obj2, turn it into a list of segments- segs = concat $ map segify $ symbolicGetOrientedContour res obj2+ segs = foldMap segify $ symbolicGetOrientedContour res obj2 -- Create sides for the main body of our object = segs × (r,h-r) -- Many layers...- side_tris = map flipTri $ concat $- [concat $ map (\(a,b) -> segToSide m a b) segs | m <- [0.. n-1] ]+ side_tris = fmap flipTri $ fold $+ [foldMap (\(a,b) -> segToSide m a b) segs | m <- [0.. n-1] ] -- Triangles that fill the contour. Make sure the mesh is at least (res/5) fine. -- --res/5 because xyres won't always match up with normal res and we need to compensate. fill_tris = {-divideMeshTo (res/5) $-} symbolicGetContourMesh res obj2 -- The bottom. Use dh to determine the z coordinates- bottom_tris = [((a1,a2,r-dh a1 a2), (b1,b2,r - dh b1 b2), (c1,c2,r - dh c1 c2)) + bottom_tris = [((a1,a2,r-dh a1 a2), (b1,b2,r - dh b1 b2), (c1,c2,r - dh c1 c2)) | ((a1,a2),(b1,b2),(c1,c2)) <- fill_tris] -- Same idea at the top.- top_tris = map flipTri $ [((a1,a2,h' (a1,a2) -r+dh a1 a2), (b1,b2,h' (b1,b2) -r+dh b1 b2), (c1,c2,h' (c1,c2)-r+dh c1 c2)) + top_tris = fmap flipTri $ [((a1,a2,h' (a1,a2) -r+dh a1 a2), (b1,b2,h' (b1,b2) -r+dh b1 b2), (c1,c2,h' (c1,c2)-r+dh c1 c2)) | ((a1,a2),(b1,b2),(c1,c2)) <- fill_tris] -- Mesh modifiers in individual components k = 2*pi/360@@ -190,20 +184,20 @@ scale' z *((x+tx)*sin(k*twist' z) - (y+ty)*cos(k*twist' z)) -- function to transform a triangle transformTriangle :: (ℝ3,ℝ3,ℝ3) -> (ℝ3,ℝ3,ℝ3)- transformTriangle (a@(_,_,z1), b@(_,_,z2), c@(_,_,z3)) = + transformTriangle (a@(_,_,z1), b@(_,_,z2), c@(_,_,z3)) = ((fx a, fy a, z1), (fx b, fy b, z2), (fx c, fy c, z3)) in- map transformTriangle (side_tris ++ bottom_tris ++ top_tris)+ fmap transformTriangle (side_tris <> bottom_tris <> top_tris) -} -symbolicGetMesh res inputObj@(UnionR3 r objs) = +symbolicGetMesh res inputObj@(UnionR3 r objs) = TriangleMesh $ let- boxes = map getBox3 objs+ boxes = fmap getBox3 objs boxedObjs = zip boxes objs- - sepFree :: forall a. [((ℝ3, ℝ3), a)] -> ([a], [a])- sepFree ((box,obj):others) = ++ sepFree :: [((ℝ3, ℝ3), a)] -> ([a], [a])+ sepFree ((box,obj):others) = if length (filter (box3sWithin r box) boxes) > 1 then first ((:) obj) $ sepFree others else second ((:) obj) $ sepFree others@@ -212,17 +206,17 @@ (dependants, independents) = sepFree boxedObjs in if null independents then case rebound3 (getImplicit3 inputObj, getBox3 inputObj) of- (obj, (a,b)) -> getMesh a b res obj + (obj, (a,b)) -> unmesh $ getMesh a b (res,res,res) obj else if null dependants- then concatMap (symbolicGetMesh res) independents- else concatMap (symbolicGetMesh res) independents- ++ symbolicGetMesh res (UnionR3 r dependants)+ then foldMap (unmesh . symbolicGetMesh res) independents+ else foldMap (unmesh . symbolicGetMesh res) independents+ <> unmesh (symbolicGetMesh res (UnionR3 r dependants)) --- If all that fails, coerce and apply marching cubes :(--- (rebound is for being safe about the bounding box ----- it slightly streches it to make sure nothing will --- have problems because it is right at the edge )+-- | If all that fails, coerce and apply marching cubes :( symbolicGetMesh res obj =- case rebound3 (getImplicit3 obj, getBox3 obj) of- (obj', (a,b)) -> getMesh a b res obj'+ -- Use rebound3 to stretch bounding box.+ case rebound3 (getImplicit3 obj, getBox3 obj) of+ (obj', (a,b)) -> getMesh a b (res,res,res) obj' +unmesh :: TriangleMesh -> [Triangle]+unmesh (TriangleMesh m) = m
Graphics/Implicit/Export/TextBuilderUtils.hs view
@@ -6,54 +6,44 @@ -- Data.Text.Lazy builders with. module Graphics.Implicit.Export.TextBuilderUtils (- -- Values from Data.Text.Lazy- Text,- pack,- -- Values from Data.Text.Lazy.Builder, as well as some special builders- Builder,+ -- From Data.Text.Lazy+ module DTL,+ -- From Data.Text.Lazy.Builder+ module DTLB, toLazyText,- fromLazyText,- buildInt,- -- Serialize a float in full precision+ -- some special case Builders. bf,- -- Serialize a float with four decimal places buildTruncFloat,- -- Values from Data.Monoid- (<>),- mconcat,- mempty+ buildℕ,+ buildInt ) where -import Prelude (Maybe(Nothing, Just), ($))+import Prelude (Maybe(Nothing, Just), Int, ($)) -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.-import Data.Monoid (Monoid, mappend, mconcat, mempty)+import Graphics.Implicit.Definitions (ℝ, ℕ, fromℝtoFloat)+import Data.Text.Lazy as DTL (Text, pack) import Data.Text.Internal.Lazy (defaultChunkSize)-import Data.Text.Lazy.Builder (Builder, toLazyTextWith, fromLazyText)+import Data.Text.Lazy.Builder as DTLB (Builder, toLazyTextWith, fromLazyText) import Data.Text.Lazy.Builder.RealFloat (formatRealFloat, FPFormat(Exponent, Fixed)) import Data.Text.Lazy.Builder.Int (decimal) -import Graphics.Implicit.Definitions (ℝ)- -- The chunk size for toLazyText is very small (128 bytes), so we export -- a version with a much larger size (~16 K) toLazyText :: Builder -> Text toLazyText = toLazyTextWith defaultChunkSize -bf, buildTruncFloat :: ℝ -> Builder--bf = formatRealFloat Exponent Nothing+-- | Serialize a float in full precision+bf :: ℝ -> Builder+bf value = formatRealFloat Exponent Nothing $ fromℝtoFloat value +-- | Serialize a float with four decimal places+buildTruncFloat :: ℝ -> Builder buildTruncFloat = formatRealFloat Fixed $ Just 4 -buildInt :: Fastℕ -> Builder+buildℕ :: ℕ -> Builder+buildℕ = decimal++buildInt :: Int -> Builder buildInt = decimal --- This is directly copied from base 4.5.1.0-infixr 6 <>-(<>) :: Monoid m => m -> m -> m-(<>) = mappend
Graphics/Implicit/Export/TriangleMeshFormats.hs view
@@ -2,39 +2,64 @@ -- Copyright (C) 2014, 2015, 2016 Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}- -- Make string litearls more polymorphic, so we can use them with Builder. {-# LANGUAGE OverloadedStrings #-} -- 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, ($), (+), map, (.), realToFrac, toEnum, length, zip, return)+import Prelude (Float, Eq, Bool, ($), (+), (.), toEnum, length, zip, pure, (==), (||), (&&), filter, not, (<>)) -import Graphics.Implicit.Definitions (Triangle, TriangleMesh, Fastℕ, ℝ3)-import Graphics.Implicit.Export.TextBuilderUtils (Text, Builder, toLazyText, (<>), bf, buildInt)+import Graphics.Implicit.Definitions (Triangle(Triangle), TriangleMesh(TriangleMesh), ℕ, ℝ3, ℝ, fromℝtoFloat)+import Graphics.Implicit.Export.TextBuilderUtils (Text, Builder, toLazyText, bf, buildℕ) 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.Foldable(fold, foldMap) import Data.ByteString (replicate) import Data.ByteString.Lazy (ByteString) import Data.Storable.Endian (LittleEndian(LE)) -import Data.VectorSpace (normalized, negateV)+import Data.VectorSpace (normalized, (^-^)) import Data.Cross (cross3) +unmesh :: TriangleMesh -> [Triangle]+unmesh (TriangleMesh m) = m+ normal :: (ℝ3,ℝ3,ℝ3) -> ℝ3 normal (a,b,c) =- normalized $ (b + negateV a) `cross3` (c + negateV a)+ normalized $ (b ^-^ a) `cross3` (c ^-^ a) +-- | Removes triangles that are empty when converting their positions to Float resolution.+cleanupTris :: TriangleMesh -> TriangleMesh+cleanupTris tris =+ let+ floatPoint :: (ℝ, ℝ, ℝ) -> (Float, Float, Float)+ floatPoint (a,b,c) = (toFloat a, toFloat b, toFloat c)++ -- | Does this triangle fail because it is constrained on two axises?+ isDegenerateTri2Axis :: Eq a => ((a, a, a),(a, a, a),(a, a, a)) -> Bool+ isDegenerateTri2Axis tri = (ysame tri && xsame tri) || (zsame tri && ysame tri) || (zsame tri && xsame tri)+ where+ same :: Eq a => (a, a, a) -> Bool+ same (n1, n2, n3) = n1 == n2 && n2 == n3+ xsame :: Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool+ xsame ((x1,_,_),(x2,_,_),(x3,_,_)) = same (x1, x2, x3)+ ysame :: Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool+ ysame ((_,y1,_),(_,y2,_),(_,y3,_)) = same (y1, y2, y3)+ zsame :: Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool+ zsame ((_,_,z1),(_,_,z2),(_,_,z3)) = same (z1, z2, z3)+ isDegenerateTri :: Triangle -> Bool+ isDegenerateTri (Triangle (a, b, c)) = isDegenerateTri2Axis floatTri -- || (isDegenerateTriLine $ floatTri) || (isDegenerateTriPoint $ floatTri)+ where+ floatTri = (floatPoint a, floatPoint b, floatPoint c)+ in TriangleMesh $ filter (not . isDegenerateTri) (unmesh tris)++-- | Generate an STL file is ASCII format. stl :: TriangleMesh -> Text-stl triangles = toLazyText $ stlHeader <> mconcat (map triangle triangles) <> stlFooter+stl triangles = toLazyText $ stlHeader <> foldMap triangle (unmesh $ cleanupTris triangles) <> stlFooter where stlHeader :: Builder stlHeader = "solid ImplictCADExport\n"@@ -44,8 +69,8 @@ vector (x,y,z) = bf x <> " " <> bf y <> " " <> bf z vertex :: ℝ3 -> Builder vertex v = "vertex " <> vector v- triangle :: (ℝ3, ℝ3, ℝ3) -> Builder- triangle (a,b,c) =+ triangle :: Triangle -> Builder+ triangle (Triangle (a,b,c)) = "facet normal " <> vector (normal (a,b,c)) <> "\n" <> "outer loop\n" <> vertex a <> "\n"@@ -53,61 +78,57 @@ <> vertex c <> "\nendloop\nendfacet\n" ---- Write a 32-bit little-endian float to a buffer.---- convert Floats and Doubles to Float.-toFloat :: Real a => a -> Float-toFloat = realToFrac :: (Real a) => a -> Float+-- | convert from ℝ to Float.+toFloat :: ℝ -> Float+toFloat = fromℝtoFloat +-- | Write a 32-bit little-endian float to a buffer. float32LE :: Float -> Write float32LE = writeStorable . LE +-- | Generate an STL file in it's binary format. binaryStl :: TriangleMesh -> ByteString-binaryStl triangles = toLazyByteString $ header <> lengthField <> mconcat (map triangle triangles)+binaryStl triangles = toLazyByteString $ header <> lengthField <> foldMap triangle (unmesh $ cleanupTris triangles) where header = fromByteString $ replicate 80 0- lengthField = fromWord32le $ toEnum $ length triangles- triangle (a,b,c) = normalV (a,b,c) <> point a <> point b <> point c <> fromWord16le 0- point :: forall a a1 a2. (Real a2, Real a1, Real a) => (a, a1, a2) -> BI.Builder+ lengthField = fromWord32le $ toEnum $ length $ unmesh $ cleanupTris triangles+ triangle (Triangle (a,b,c)) = normalV (a,b,c) <> point a <> point b <> point c <> fromWord16le 0+ point :: ℝ3 -> BI.Builder point (x,y,z) = fromWrite $ float32LE (toFloat x) <> float32LE (toFloat y) <> float32LE (toFloat z)- normalV ps = let (x,y,z) = normal ps- in fromWrite $ float32LE (toFloat x) <> float32LE (toFloat y) <> float32LE (toFloat z)+ normalV ps = point $ normal ps jsTHREE :: TriangleMesh -> Text jsTHREE triangles = toLazyText $ header <> vertcode <> facecode <> footer where -- some dense JS. Let's make helper functions so that we don't repeat code each line header :: Builder- header = mconcat [- "var Shape = function(){\n"- ,"var s = this;\n"- ,"THREE.Geometry.call(this);\n"- ,"function vec(x,y,z){return new THREE.Vector3(x,y,z);}\n"- ,"function v(x,y,z){s.vertices.push(vec(x,y,z));}\n"- ,"function f(a,b,c){"- ,"s.faces.push(new THREE.Face3(a,b,c));"- ,"}\n" ]+ header = "var Shape = function(){\n"+ <> "var s = this;\n"+ <> "THREE.Geometry.call(this);\n"+ <> "function vec(x,y,z){return new THREE.Vector3(x,y,z);}\n"+ <> "function v(x,y,z){s.vertices.push(vec(x,y,z));}\n"+ <> "function f(a,b,c){"+ <> "s.faces.push(new THREE.Face3(a,b,c));"+ <> "}\n" footer :: Builder- footer = mconcat [- "}\n"- ,"Shape.prototype = new THREE.Geometry();\n"- ,"Shape.prototype.constructor = Shape;\n" ]+ footer = "}\n"+ <> "Shape.prototype = new THREE.Geometry();\n"+ <> "Shape.prototype.constructor = Shape;\n" -- A vertex line; v (0.0, 0.0, 1.0) = "v(0.0,0.0,1.0);\n" v :: ℝ3 -> Builder v (x,y,z) = "v(" <> bf x <> "," <> bf y <> "," <> bf z <> ");\n" -- A face line- f :: Fastℕ -> Fastℕ -> Fastℕ -> Builder- f posa posb posc = - "f(" <> buildInt posa <> "," <> buildInt posb <> "," <> buildInt posc <> ");"+ f :: ℕ -> ℕ -> ℕ -> Builder+ f posa posb posc =+ "f(" <> buildℕ posa <> "," <> buildℕ posb <> "," <> buildℕ posc <> ");" verts = do -- extract the vertices for each triangle -- recall that a normed triangle is of the form ((vert, norm), ...)- (a,b,c) <- triangles+ (Triangle (a,b,c)) <- unmesh $ cleanupTris triangles -- The vertices from each triangle take up 3 position in the resulting list [a,b,c]- vertcode = mconcat $ map v verts- facecode = mconcat $ do- (n,_) <- zip [0, 3 ..] triangles+ vertcode = foldMap v verts+ facecode = fold $ do+ (n,_) <- zip [0, 3 ..] $ unmesh $ cleanupTris triangles let- (posa, posb, posc) = (n, n+1, n+2) :: (Fastℕ, Fastℕ, Fastℕ)- return $ f posa posb posc+ (posa, posb, posc) = (n, n+1, n+2) :: (ℕ, ℕ, ℕ)+ pure $ f posa posb posc
Graphics/Implicit/Export/Util.hs view
@@ -2,29 +2,35 @@ -- Copyright 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- FIXME: why are these needed?-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}+-- For the definition of centroid.+{-# LANGUAGE FlexibleContexts #-} -- Functions to make meshes/polylines finer. module Graphics.Implicit.Export.Util (normTriangle, normVertex, centroid) where -import Prelude(Fractional, (/), (-), ($), foldl, recip, realToFrac, length)+import Prelude(Fractional, (/), (-), ($), foldl, realToFrac, length) -import Graphics.Implicit.Definitions (ℝ, ℝ3, Obj3, Triangle, NormedTriangle)+import Graphics.Implicit.Definitions (ℝ, ℝ3, Obj3, Triangle(Triangle), NormedTriangle(NormedTriangle)) import Data.VectorSpace (VectorSpace, Scalar, (^+^), (*^), (^/), (^-^), normalized, zeroV) +-- | Change the default for bare numbers in this file.+default (ℝ)++-- FIXME: magic numbers. normTriangle :: ℝ -> Obj3 -> Triangle -> NormedTriangle-normTriangle res obj (a,b,c) =- (normify a', normify b', normify c')+normTriangle res obj (Triangle (a,b,c)) =+ NormedTriangle (normify a', normify b', normify c') where normify = normVertex res obj a' = (a ^+^ r*^b ^+^ r*^c) ^/ 1.02 b' = (b ^+^ r*^a ^+^ r*^c) ^/ 1.02 c' = (c ^+^ r*^b ^+^ r*^a) ^/ 1.02- r = 0.01 :: ℝ+ r :: ℝ+ r = 0.01 +-- FIXME: magic numbers. normVertex :: ℝ -> Obj3 -> ℝ3 -> (ℝ3, ℝ3) normVertex res obj p = let@@ -40,14 +46,14 @@ dz = d (0, 0, 1) in (p, normalized (dx,dy,dz)) +-- Get a centroid of a series of points. centroid :: (VectorSpace v, Fractional (Scalar v)) => [v] -> v-centroid pts =- (norm *^) $ foldl (^+^) zeroV pts- where- norm :: Fractional a => a- norm = recip $ realToFrac $ length pts+centroid pts = foldl (^+^) zeroV pts ^/ (realToFrac $ length pts)+{-# INLINABLE centroid #-} -{--- If we need to make a 2D mesh finer...+{-++-- If we need to make a 2D mesh finer... divideMesh2To :: ℝ -> [(ℝ2, ℝ2, ℝ2)] -> [(ℝ2, ℝ2, ℝ2)] divideMesh2To res mesh = let@@ -68,7 +74,7 @@ (av b c, av a c, av a b)] (_,_,_) -> divideTriangle (c, a, b) in- concat $ map divideTriangle mesh+ foldMap divideTriangle mesh divideMeshTo :: ℝ -> [(ℝ3, ℝ3, ℝ3)] -> [(ℝ3, ℝ3, ℝ3)] divideMeshTo res mesh =@@ -90,7 +96,7 @@ (av b c, av a c, av a b)] (_,_,_) -> divideTriangle (c, a, b) in- concat $ map divideTriangle mesh+ foldMap divideTriangle mesh dividePolylineTo :: ℝ -> [ℝ2] -> [ℝ2] dividePolylineTo res polyline =@@ -100,13 +106,11 @@ divide a b = if S.norm (a S.- b) <= res then [a]- else concat [divide a (av a b), divide (av a b) b]+ else divide a (av a b) <> divide (av a b) b n = length polyline in do m <- [0.. n] if m /= n then divide (polyline !! m) (polyline !! (m+1)) else [polyline !! n]-- -}
Graphics/Implicit/ExtOpenScad.hs view
@@ -2,41 +2,54 @@ -- Copyright (C) 2014 2015 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- FIXME: why are these required?-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}---- We'd like to parse openscad code, with some improvements, for backwards compatability.+-- allow us to specify what package to import what module from.+-- We don't actually care, but when we compile our haskell examples, we do.+{-# LANGUAGE PackageImports #-} +-- An executor, which parses openscad code, and executes it. module Graphics.Implicit.ExtOpenScad (runOpenscad) where -import Prelude(String, Either(Left, Right), IO, ($), fmap)+import Prelude(String, IO, ($), (<$>), pure, either, (.), Applicative) import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3)-import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup, OVal)++import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup, ScadOpts, Message(Message), MessageType(SyntaxError), CompState(CompState, scadVars, oVals, messages), StatementI)+ import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram)++import Graphics.Implicit.ExtOpenScad.Parser.Util (sourcePosition)+ import Graphics.Implicit.ExtOpenScad.Eval.Statement (runStatementI)-import Graphics.Implicit.ExtOpenScad.Default (defaultObjects)++import Graphics.Implicit.ExtOpenScad.Eval.Constant (addConstants)+ import Graphics.Implicit.ExtOpenScad.Util.OVal (divideObjs) -import qualified Text.Parsec.Error as Parsec (ParseError)-import qualified Control.Monad as Monad (mapM_)-import qualified Control.Monad.State as State (runStateT)-import qualified System.Directory as Dir (getCurrentDirectory)+import Text.Parsec.Error (errorPos, errorMessages, showErrorMessages, ParseError) --- Small wrapper to handle parse errors, etc.-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 source of- Left e -> Left e- Right sts -> Right- $ fmap rearrange- $ (\sts' -> do- path <- Dir.getCurrentDirectory- State.runStateT sts' (initial, [], path, (), () )- )- $ Monad.mapM_ runStatementI sts+import "monads-tf" Control.Monad.State.Lazy (runStateT)++import System.Directory (getCurrentDirectory)++import Data.Foldable (traverse_)++-- | Small wrapper of our parser to handle parse errors, etc.+runOpenscad :: ScadOpts -> [String] -> String -> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])+runOpenscad scadOpts constants source = do+ (initialObjects, initialMessages) <- addConstants constants+ let+ err :: Applicative f => ParseError -> f (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])+ err e = pure (initialObjects, [], [], mesg e : initialMessages)+ run :: [StatementI] -> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])+ run sts = rearrange <$> do+ let sts' = traverse_ runStatementI sts+ path <- getCurrentDirectory+ runStateT sts' $ CompState initialObjects [] path initialMessages scadOpts+ either err run $ parseProgram "" source+ where+ rearrange :: ((), CompState) -> (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])+ rearrange (_, s) =+ let (obj2s, obj3s, _) = divideObjs $ oVals s+ in (scadVars s, obj2s, obj3s, messages s)+ show' = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . errorMessages+ mesg e = Message SyntaxError (sourcePosition $ errorPos e) $ show' e
Graphics/Implicit/ExtOpenScad/Default.hs view
@@ -2,115 +2,168 @@ -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}---- We'd like to parse openscad code, with some improvements, for backwards compatability.-+-- allow us to specify what package to import what module from.+-- We don't actually care, but when we compile our haskell examples, we do.+{-# LANGUAGE PackageImports #-} module Graphics.Implicit.ExtOpenScad.Default (defaultObjects) where -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)+-- be explicit about where we pull things in from.+import Prelude (String, Bool(True, False), Maybe(Just, Nothing), ($), (<>), fmap, 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, (-), otherwise, id, foldMap) -import Graphics.Implicit.Definitions (ℝ, Fastℕ)-import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup, OVal(OList, ONum, OString, OUndefined, OError, OModule, OFunc))+import Graphics.Implicit.Definitions (ℝ, ℕ)+import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup(VarLookup), OVal(OBool, OList, ONum, OString, OUndefined, OError, OFunc, OVargsModule), Symbol(Symbol), StateC, StatementI, SourcePosition, MessageType(TextOut, Warning), ScadOpts(ScadOpts)) import Graphics.Implicit.ExtOpenScad.Util.OVal (toOObj, oTypeStr)-import Graphics.Implicit.ExtOpenScad.Primitives (primitives)-import Data.Map (fromList)-import Control.Arrow (second)+import Graphics.Implicit.ExtOpenScad.Primitives (primitiveModules)+import Graphics.Implicit.ExtOpenScad.Util.StateC (scadOptions, modifyVarLookup, addMessage)+import Data.Map (Map, fromList, insert)+import Data.List (genericIndex, genericLength, intercalate)+import Data.Foldable (for_) -defaultObjects :: VarLookup -- = Map String OVal-defaultObjects = fromList $+defaultObjects :: VarLookup+defaultObjects = VarLookup $ fromList $ defaultConstants- ++ defaultFunctions- ++ defaultFunctions2- ++ defaultFunctionsSpecial- ++ defaultModules- ++ defaultPolymorphicFunctions+ <> defaultFunctions+ <> defaultFunctions2+ <> defaultFunctionsSpecial+ <> defaultPolymorphicFunctions+ <> primitiveModules+ <> varArgModules --- Missing standard ones:+-- FIXME: Missing standard ones(which standard?): -- rand, lookup, -defaultConstants :: [(String, OVal)]-defaultConstants = map (\(a,b) -> (a, toOObj (b::ℝ) ))- [("pi", pi)]+defaultConstants :: [(Symbol, OVal)]+defaultConstants = fmap (\(a,b) -> (a, toOObj (b :: ℝ) ))+ [(Symbol "pi", pi),+ (Symbol "PI", pi)] -defaultFunctions :: [(String, OVal)]-defaultFunctions = map (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ)))+defaultFunctions :: [(Symbol, OVal)]+defaultFunctions = fmap (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ))) [- ("sin", sin),- ("cos", cos),- ("tan", tan),- ("asin", asin),- ("acos", acos),- ("atan", atan),- ("sinh", sinh),- ("cosh", cosh),- ("tanh", tanh),- ("abs", abs),- ("sign", signum),- ("floor", fromInteger . floor ),- ("ceil", fromInteger . ceiling ),- ("round", fromInteger . round ),- ("exp", exp),- ("ln", log),- ("log", log),- ("sign", signum),- ("sqrt", sqrt)+ (Symbol "sin", sin),+ (Symbol "cos", cos),+ (Symbol "tan", tan),+ (Symbol "asin", asin),+ (Symbol "acos", acos),+ (Symbol "atan", atan),+ (Symbol "sinh", sinh),+ (Symbol "cosh", cosh),+ (Symbol "tanh", tanh),+ (Symbol "abs", abs),+ (Symbol "sign", signum),+ (Symbol "floor", fromInteger . floor ),+ (Symbol "ceil", fromInteger . ceiling ),+ (Symbol "round", fromInteger . round ),+ (Symbol "exp", exp),+ (Symbol "ln", log),+ (Symbol "log", log),+ (Symbol "sign", signum),+ (Symbol "sqrt", sqrt) ] -defaultFunctions2 :: [(String, OVal)]-defaultFunctions2 = map (\(a,b) -> (a, toOObj (b :: ℝ -> ℝ -> ℝ) ))+defaultFunctions2 :: [(Symbol, OVal)]+defaultFunctions2 = fmap (\(a,b) -> (a, toOObj (b :: ℝ -> ℝ -> ℝ) )) [- ("max", max),- ("min", min),- ("atan2", atan2),- ("pow", (**))+ (Symbol "max", max),+ (Symbol "min", min),+ (Symbol "atan2", atan2),+ (Symbol "pow", (**)) ] -defaultFunctionsSpecial :: [(String, OVal)]+defaultFunctionsSpecial :: [(Symbol, OVal)] defaultFunctionsSpecial = [- ("map", toOObj $ flip- (map :: (OVal -> OVal) -> [OVal] -> [OVal] )+ (Symbol "map", toOObj $ flip+ (fmap :: (OVal -> OVal) -> [OVal] -> [OVal] ) )- ] -defaultModules :: [(String, OVal)]-defaultModules =- map (second OModule) primitives+varArgModules :: [(Symbol, OVal)]+varArgModules =+ [+ modVal "echo" echo+ ,modVal "for" for+ ,modVal "color" executeSuite+ ] where+ modVal name func = (Symbol name, OVargsModule name func) --- more complicated ones:+ -- execute only the child statement, without doing anything else. Useful for unimplemented functions.+ executeSuite :: String -> SourcePosition -> [(Maybe Symbol, OVal)] -> [StatementI] -> ([StatementI] -> StateC ()) -> StateC ()+ executeSuite name pos _ suite runSuite = do+ addMessage Warning pos $ "Module " <> name <> " not implemented"+ runSuite suite -defaultPolymorphicFunctions :: [(String, OVal)]+ echo :: String -> SourcePosition -> [(Maybe Symbol, OVal)] -> [StatementI] -> ([StatementI] -> StateC ()) -> StateC ()+ echo _ pos args suite runSuite = do+ scadOpts <- scadOptions+ let+ text :: [(Maybe Symbol, OVal)] -> String+ text a = intercalate ", " $ fmap show' a+ show' :: (Maybe Symbol, OVal) -> String+ show' (Nothing, arg) = show arg+ show' (Just (Symbol var), arg) = var <> " = " <> show arg+ showe' (Nothing, OString arg) = arg+ showe' (Just (Symbol var), arg) = var <> " = " <> showe' (Nothing, arg)+ showe' a = show' a+ compat (ScadOpts compat_flag _) = compat_flag+ openScadFormat = "ECHO: " <> text args+ extopenscadFormat = foldMap showe' args+ formattedMessage = if compat scadOpts then openScadFormat else extopenscadFormat+ addMessage TextOut pos formattedMessage+ runSuite suite++ for :: String -> SourcePosition -> [(Maybe Symbol, OVal)] -> [StatementI] -> ([StatementI] -> StateC ()) -> StateC ()+ for _ _ args suite runSuite =+ for_ (iterator args) $ \iter -> do+ modifyVarLookup iter+ runSuite suite+ where+ -- | convert a list of arguments into a list of functions to transform the VarLookup with new bindings for each possible iteration.+ iterator :: [(Maybe Symbol, OVal)] -> [VarLookup -> VarLookup]+ iterator [] = [id]+ iterator ((Nothing, _):iterators) = iterator iterators+ iterator ((Just var, vals):iterators) = [outer . varify inner | inner <- fmap (insert var) (valsList vals), outer <- iterator iterators]+ -- convert the loop iterator variable's expression value to a list (possibly of one value)+ valsList :: OVal -> [OVal]+ valsList v@(OBool _) = [v]+ valsList v@(ONum _) = [v]+ valsList v@(OString _) = [v]+ valsList (OList vs) = vs+ valsList _ = []+ -- promote a result into a VarLookup+ varify :: (Map Symbol OVal -> Map Symbol OVal) -> VarLookup -> VarLookup+ varify f (VarLookup v) = VarLookup $ f v++-- | more complicated ones:+defaultPolymorphicFunctions :: [(Symbol, OVal)] defaultPolymorphicFunctions = [- ("+", sumtotal),- ("sum", sumtotal),- ("*", prod),- ("prod", prod),- ("/", divide),- ("-", toOObj sub),- ("%", toOObj omod),- ("^", toOObj ((**) :: ℝ -> ℝ -> ℝ)),- ("negate", toOObj negatefun),- ("index", toOObj index),- ("splice", toOObj osplice),- ("<", toOObj ((<) :: ℝ -> ℝ -> Bool) ),- (">", toOObj ((>) :: ℝ -> ℝ -> Bool) ),- (">=", toOObj ((>=) :: ℝ -> ℝ -> Bool) ),- ("<=", toOObj ((<=) :: ℝ -> ℝ -> Bool) ),- ("==", toOObj ((==) :: OVal -> OVal -> Bool) ),- ("!=", toOObj ((/=) :: OVal -> OVal -> Bool) ),- ("?", toOObj ( ternary :: Bool -> OVal -> OVal -> OVal) ),- ("&&", toOObj (&&) ),- ("||", toOObj (||) ),- ("!", toOObj not ),- ("list_gen", toOObj list_gen),- ("++", concatenate),- ("len", toOObj olength),- ("str", toOObj (show :: OVal -> String))+ (Symbol "+", sumtotal),+ (Symbol "sum", sumtotal),+ (Symbol "*", prod),+ (Symbol "prod", prod),+ (Symbol "/", divide),+ (Symbol "-", toOObj sub),+ (Symbol "%", toOObj omod),+ (Symbol "^", toOObj ((**) :: ℝ -> ℝ -> ℝ)),+ (Symbol "negate", toOObj negatefun),+ (Symbol "index", toOObj index),+ (Symbol "splice", toOObj osplice),+ (Symbol "<", toOObj ((<) :: ℝ -> ℝ -> Bool) ),+ (Symbol ">", toOObj ((>) :: ℝ -> ℝ -> Bool) ),+ (Symbol ">=", toOObj ((>=) :: ℝ -> ℝ -> Bool) ),+ (Symbol "<=", toOObj ((<=) :: ℝ -> ℝ -> Bool) ),+ (Symbol "==", toOObj ((==) :: OVal -> OVal -> Bool) ),+ (Symbol "!=", toOObj ((/=) :: OVal -> OVal -> Bool) ),+ (Symbol "?", toOObj ( ternary :: Bool -> OVal -> OVal -> OVal) ),+ (Symbol "&&", toOObj (&&) ),+ (Symbol "||", toOObj (||) ),+ (Symbol "!", toOObj not ),+ (Symbol "list_gen", toOObj list_gen),+ (Symbol "<>", concatenate),+ (Symbol "len", toOObj olength),+ (Symbol "str", toOObj (show :: OVal -> String)) ] where -- Some key functions are written as OVals in optimizations attempts@@ -118,12 +171,18 @@ prod = OFunc $ \x -> case x of (OList (y:ys)) -> foldl mult y ys (OList []) -> ONum 1- _ -> OError ["Product takes a list"]+ (ONum a) -> OFunc $ \y -> case y of+ (OList []) -> ONum a+ (OList n) -> mult (ONum a) (OList n)+ (ONum b) -> mult (ONum a) (ONum b)+ _ -> OError ["prod takes only lists or nums"]+ _ -> OError ["prod takes only lists or nums"] mult (ONum a) (ONum b) = ONum (a*b)- mult (ONum a) (OList b) = OList (map (mult (ONum a)) b)- mult (OList a) (ONum b) = OList (map (mult (ONum b)) a)- mult a b = errorAsAppropriate "multiply" a b+ mult (ONum a) (OList b) = OList (fmap (mult (ONum a)) b)+ mult (OList a) (ONum b) = OList (fmap (mult (ONum b)) a)+ mult (OList a) (OList b) = OList $ zipWith mult a b+ mult a b = errorAsAppropriate "product" a b divide = OFunc $ \x -> case x of (ONum a) -> OFunc $ \y -> case y of@@ -133,27 +192,34 @@ b -> div' a b div' (ONum a) (ONum b) = ONum (a/b)- div' (OList a) (ONum b) = OList (map (\x -> div' x (ONum b)) a)+ div' (OList a) (ONum b) = OList (fmap (\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 a b = errorAsAppropriate "modulo" a b-- append (OList a) (OList b) = OList $ a++b- append (OString a) (OString b) = OString $ a++b- append a b = errorAsAppropriate "append" a b+ omod a b = errorAsAppropriate "mod" a b concatenate = OFunc $ \x -> case x of (OList (y:ys)) -> foldl append y ys (OList []) -> OList [] _ -> OError ["concat takes a list"] + append (OList a) (OList b) = OList $ a<>b+ append (OString a) (OString b) = OString $ a<>b+ append a b = errorAsAppropriate "concat" a b+ sumtotal = OFunc $ \x -> case x of (OList (y:ys)) -> foldl add y ys (OList []) -> ONum 0- _ -> OError ["Sum takes a list"]+ (ONum a) -> OFunc $ \y -> case y of+ (OList []) -> ONum a+ (OList n) -> add (ONum a) (OList n)+ (ONum b) -> add (ONum a) (ONum b)+ _ -> OError ["sum takes two lists or nums"]+ _ -> OError ["sum takes two lists or nums"] add (ONum a) (ONum b) = ONum (a+b)+ add (ONum a) (OList b) = OList (fmap (add (ONum a)) b)+ add (OList a) (ONum b) = OList (fmap (add (ONum b)) a) add (OList a) (OList b) = OList $ zipWith add a b add a b = errorAsAppropriate "add" a b @@ -162,8 +228,8 @@ sub a b = errorAsAppropriate "subtract" a b negatefun (ONum n) = ONum (-n)- negatefun (OList l) = OList $ map negatefun l- negatefun a = OError ["Can't negate " ++ oTypeStr a ++ "(" ++ show a ++ ")"]+ negatefun (OList l) = OList $ fmap negatefun l+ negatefun a = OError ["Can't negate " <> oTypeStr a <> "(" <> show a <> ")"] {-numCompareToExprCompare :: (ℝ -> ℝ -> Bool) -> Oval -> OVal -> Bool numCompareToExprCompare f a b =@@ -173,15 +239,15 @@ index (OList l) (ONum ind) = let- n :: Fastℕ+ n :: ℕ n = floor ind in- if n < length l then l !! n else OError ["List accessd out of bounds"]+ if n < genericLength l then l `genericIndex` n else OError ["List accessd out of bounds"] index (OString s) (ONum ind) = let- n :: Fastℕ+ n :: ℕ n = floor ind- in if n < length s then OString [s !! n] else OError ["List accessd out of bounds"]+ in if n < genericLength s then OString [s `genericIndex` n] else OError ["List accessd out of bounds"] index a b = errorAsAppropriate "index" a b osplice (OList list) (ONum a) ( ONum b ) =@@ -193,49 +259,50 @@ osplice (OString str) OUndefined (ONum b ) = OString $ splice str 0 (floor b) osplice (OList list) (ONum a) OUndefined =- OList $ splice list (floor a) (length list + 1)+ OList $ splice list (floor a) (genericLength list + 1) osplice (OString str) (ONum a) OUndefined =- OString $ splice str (floor a) (length str + 1)+ OString $ splice str (floor a) (genericLength str + 1) osplice (OList list) OUndefined OUndefined =- OList $ splice list 0 (length list + 1)+ OList $ splice list 0 (genericLength list + 1) osplice (OString str) OUndefined OUndefined =- OString $ splice str 0 (length str + 1)+ OString $ splice str 0 (genericLength str + 1) osplice _ _ _ = OUndefined - splice :: [a] -> Fastℕ -> Fastℕ -> [a]+ splice :: [a] -> ℕ -> ℕ -> [a] splice [] _ _ = []- splice (l@(x:xs)) a b+ splice l@(x:xs) a b | a < 0 = splice l (a+n) b | b < 0 = splice l a (b+n) | a > 0 = splice xs (a-1) (b-1) | b > 0 = x: splice xs a (b-1) | otherwise = []- where n = length l+ where+ n :: ℕ+ n = genericLength l errorAsAppropriate _ err@(OError _) _ = err errorAsAppropriate _ _ err@(OError _) = err errorAsAppropriate name a b = OError- ["Can't " ++ name ++ " objects of types " ++ oTypeStr a ++ " and " ++ oTypeStr b ++ "."]+ ["Can't " <> name <> " objects of types " <> oTypeStr a <> " and " <> oTypeStr b <> "."] list_gen :: [ℝ] -> Maybe [ℝ]- list_gen [a,b] = Just [fromInteger (ceiling a).. fromInteger (floor b)]+ list_gen [a, b] = Just $ fmap fromInteger [(ceiling a).. (floor b)] list_gen [a, b, c] = let nr = (c-a)/b n :: ℝ n = fromInteger (floor nr) in if nr - n > 0- then Just- [fromInteger (ceiling a), fromInteger (ceiling (a+b)).. fromInteger (floor (c - b*(nr -n)))]- else Just- [fromInteger (ceiling a), fromInteger (ceiling (a+b)).. fromInteger (floor c)]+ then Just $ fmap fromInteger+ [(ceiling a), (ceiling (a+b)).. (floor (c - b*(nr -n)))]+ else Just $ fmap fromInteger+ [(ceiling a), (ceiling (a+b)).. (floor c)] list_gen _ = Nothing - ternary :: forall t. Bool -> t -> t -> t+ ternary :: Bool -> t -> t -> t ternary True a _ = a ternary False _ b = b - 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 ++ "."]-+ olength (OString s) = ONum $ genericLength s+ olength (OList s) = ONum $ genericLength s+ olength a = OError ["Can't take length of a " <> oTypeStr a <> "."]
Graphics/Implicit/ExtOpenScad/Definitions.hs view
@@ -2,33 +2,62 @@ -- Copyright 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE +-- Allow us to specify what package to import what module from.+-- We don't actually care, but when we compile our haskell examples, we do.+{-# LANGUAGE PackageImports #-}+ module Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch, APTerminator, APFailIf, APExample),- Symbol,+ Symbol(Symbol), Pattern(Wild, Name, ListP), Expr(LitE, Var, ListE, LamE, (:$)), StatementI(StatementI),- Statement(DoNothing, NewModule, Include, Echo, If, For, ModuleCall, (:=)),- OVal(ONum, OBool, OString, OList, OFunc, OUndefined, OModule,OError, OObj2, OObj3),- VarLookup,- FStack,+ Statement(DoNothing, NewModule, Include, If, ModuleCall, (:=)),+ OVal(ONum, OBool, OString, OList, OFunc, OUndefined, OUModule, ONModule, OVargsModule, OError, OObj2, OObj3), TestInvariant(EulerCharacteristic),- collector) where+ SourcePosition(SourcePosition),+ StateC,+ CompState(CompState, scadVars, oVals, sourceDir, messages, scadOpts),+ VarLookup(VarLookup),+ Message(Message),+ MessageType(TextOut, Warning, Error, SyntaxError, Compatibility, Unimplemented),+ ScadOpts(ScadOpts, openScadCompatibility, importsAllowed),+ lookupVarIn,+ varUnion+ ) where -import Prelude(Eq, Show, String, Maybe, Bool(True, False), IO, (==), show, map, ($), (++), undefined, and, zipWith, foldl1)+import Prelude(Eq, Show, Ord, String, Maybe(Just), Bool(True, False), IO, FilePath, (==), show, ($), (<>), undefined, and, zipWith, foldl1, Int) --- Resolution of the world, Integer operator, and symbolic languages for 2D and 3D objects.-import Graphics.Implicit.Definitions (ℝ, Fastℕ, ℕ, SymbolicObj2, SymbolicObj3)+-- Resolution of the world, Integer type, and symbolic languages for 2D and 3D objects.+import Graphics.Implicit.Definitions (ℝ, ℕ, Fastℕ, SymbolicObj2, SymbolicObj3, fromFastℕ) import Control.Applicative (Applicative, Alternative((<|>), empty), pure, (<*>))+ import Control.Monad (Functor, Monad, fmap, (>>=), mzero, mplus, MonadPlus, liftM, ap, return, (>=>))-import Data.Map (Map) --------------------------------------------------------------------- | Handles parsing arguments to modules+import Data.Map (Map, lookup, union)++import Data.Maybe (fromMaybe)++import Data.List (intercalate)++import "monads-tf" Control.Monad.State (StateT)++-- | This is the state of a computation. It contains a hash of variables/functions, an array of OVals, a path, messages, and options controlling code execution.+data CompState = CompState+ { scadVars :: VarLookup+ , oVals :: [OVal]+ , sourceDir :: FilePath+ , messages :: [Message]+ , scadOpts :: ScadOpts+ }++type StateC = StateT CompState IO++-- | Handles parsing arguments to built-in modules data ArgParser a -- | For actual argument entries: -- ArgParser (argument name) (default) (doc) (next Argparser...)- = AP String (Maybe OVal) String (OVal -> ArgParser a)+ = AP Symbol (Maybe OVal) String (OVal -> ArgParser a) -- | For returns: -- ArgParserTerminator (return value) | APTerminator a@@ -55,18 +84,18 @@ -- ArgParser actually (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+ -- These next two are easy, they just pass the work along to their child (APExample str child) >>= g = APExample str (child >>= g) (APTest str tests child) >>= g = APTest str tests (child >>= g) -- And an ArgParserTerminator happily gives away the value it contains (APTerminator a) >>= g = g a- (APBranch bs) >>= g = APBranch $ map (>>= g) bs+ (APBranch bs) >>= g = APBranch $ fmap (>>= 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 (APBranch as) (APBranch bs) = APBranch ( as <> bs )+ mplus (APBranch as) b = APBranch ( as <> [b] ) mplus a (APBranch bs) = APBranch ( a : bs ) mplus a b = APBranch [ a , b ] @@ -74,37 +103,36 @@ (<|>) = mplus empty = mzero -type Symbol = String+newtype Symbol = Symbol String+ deriving (Show, Eq, Ord) -data Pattern = Name Symbol- | ListP [Pattern]+newtype VarLookup = VarLookup (Map Symbol OVal)++data Pattern = Name Symbol+ | ListP [Pattern] | Wild- | Symbol :@ Pattern deriving (Show, Eq) +-- | An expression. data Expr = Var Symbol- | LitE OVal- | ListE [Expr]- | LamE [Pattern] Expr- | Expr :$ [Expr]+ | LitE OVal -- A literal value.+ | ListE [Expr] -- A list of expressions.+ | LamE [Pattern] Expr -- A lambda expression.+ | Expr :$ [Expr] -- application of a function. deriving (Show, Eq) --- a statement, along with the line number it is found on.-data StatementI = StatementI Fastℕ (Statement StatementI)+-- | A statement, along with the line, column number, and file it is found at.+data StatementI = StatementI SourcePosition (Statement StatementI) deriving (Show, Eq) data Statement st = Include String Bool | Pattern := Expr- | Echo [Expr]- | For Pattern Expr [st] | If Expr [st] [st] | NewModule Symbol [(Symbol, Maybe Expr)] [st] | ModuleCall Symbol [(Maybe Symbol, Expr)] [st] | DoNothing deriving (Show, Eq) -- -- | Objects for our OpenSCAD-like language data OVal = OUndefined | OError [String]@@ -113,7 +141,11 @@ | OList [OVal] | OString String | OFunc (OVal -> OVal)- | OModule ([OVal] -> ArgParser (IO [OVal]))+ -- Name, arguments, argument parsers.+ | OUModule Symbol (Maybe [(Symbol, Bool)]) ([OVal] -> ArgParser (StateC [OVal]))+ -- Name, implementation, arguments, whether the module accepts/requires a suite.+ | ONModule Symbol (SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) [([(Symbol, Bool)], Maybe Bool)]+ | OVargsModule String (String -> SourcePosition -> [(Maybe Symbol, OVal)] -> [StatementI] -> ([StatementI] -> StateC ()) -> StateC ()) | OObj3 SymbolicObj3 | OObj2 SymbolicObj2 @@ -131,18 +163,72 @@ show (OList l) = show l show (OString s) = show s show (OFunc _) = "<function>"- show (OModule _) = "module"- show (OError msgs) = "Execution Error:\n" ++ foldl1 (\a b -> a ++ "\n" ++ b) msgs- show (OObj2 obj) = "<obj2: " ++ show obj ++ ">"- show (OObj3 obj) = "<obj3: " ++ show obj ++ ">"+ show (OUModule (Symbol name) arguments _) = "module " <> name <> " (" <> intercalate ", " (fmap showArg (fromMaybe [] arguments)) <> ") {}"+ where+ showArg (Symbol a, hasDefault) = if hasDefault+ then a+ else a <> "=..."+ show (ONModule (Symbol name) _ instances) = showInstances instances+ where+ showArg (Symbol a, hasDefault) = if hasDefault+ then a+ else a <> "=..."+ showInstances :: [([(Symbol, Bool)], Maybe Bool)] -> String+ showInstances [] = ""+ showInstances [oneInstance] = "module " <> name <> showInstance oneInstance+ showInstances multipleInstances = "Module " <> name <> "[ " <> intercalate ", " (fmap showInstance multipleInstances) <> " ]"+ showInstance :: ([(Symbol, Bool)], Maybe Bool) -> String+ showInstance (arguments, suiteInfo) = " (" <> intercalate ", " (fmap showArg arguments) <> ") {}" <> showSuiteInfo suiteInfo+ showSuiteInfo suiteInfo = case suiteInfo of+ Just requiresSuite -> if requiresSuite+ then " requiring suite {}"+ else " accepting suite {}"+ _ -> ""+ show (OVargsModule name _) = "varargs module " <> name+ show (OError msgs) = "Execution Error:\n" <> foldl1 (\a b -> a <> "\n" <> b) msgs+ show (OObj2 obj) = "<obj2: " <> show obj <> ">"+ show (OObj3 obj) = "<obj3: " <> show obj <> ">" -type VarLookup = Map String OVal-type FStack = [OVal]+-- | In order to not propagate Parsec or other modules around, create our own source position type for the AST.+data SourcePosition = SourcePosition+ Fastℕ -- sourceLine+ Fastℕ -- sourceColumn+ FilePath -- sourceName+ deriving (Eq) -collector :: Symbol -> [Expr] -> Expr-collector _ [x] = x-collector s l = Var s :$ [ListE l]+instance Show SourcePosition where+ show (SourcePosition line col []) = "line " <> show (fromFastℕ line :: Int) <> ", column " <> show (fromFastℕ col :: Int)+ show (SourcePosition line col filePath) = "line " <> show (fromFastℕ line :: Int) <> ", column " <> show (fromFastℕ col :: Int) <> ", file " <> filePath +-- | The types of messages the execution engine can send back to the application.+data MessageType = TextOut -- text intetionally output by the ExtOpenScad program.+ | Warning+ | Error+ | SyntaxError+ | Compatibility+ | Unimplemented+ deriving (Show, Eq)++-- | An individual message.+data Message = Message MessageType SourcePosition String+ deriving (Eq)++instance Show Message where+ show (Message mtype pos text) = show mtype <> " at " <> show pos <> ": " <> text++-- | Options changing the behavior of the extended OpenScad engine.+data ScadOpts = ScadOpts+ { openScadCompatibility :: Bool+ , importsAllowed :: Bool+ }++-- helper, to use union on VarLookups.+varUnion :: VarLookup -> VarLookup -> VarLookup+varUnion (VarLookup a) (VarLookup b) = VarLookup $ union a b++-- | For programs using this API to perform variable lookups, after execution of an escad has completed.+lookupVarIn :: String -> VarLookup -> Maybe OVal+lookupVarIn target (VarLookup vars) = lookup (Symbol target) vars+ newtype TestInvariant = EulerCharacteristic ℕ deriving (Show)-
+ Graphics/Implicit/ExtOpenScad/Eval/Constant.hs view
@@ -0,0 +1,80 @@+-- 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++-- allow us to specify what package to import what module from.+-- We don't actually care, but when we compile our haskell examples, we do.+{-# LANGUAGE PackageImports #-}++module Graphics.Implicit.ExtOpenScad.Eval.Constant (addConstants, runExpr) where++import Prelude (String, IO, ($), pure, (+), Either, Bool(False), (.), either, (<$>), (<*), (<*>))++import Data.Foldable (traverse_, foldlM)++import Graphics.Implicit.Definitions (Fastℕ)++import Graphics.Implicit.ExtOpenScad.Definitions (+ Pattern,+ Expr,+ VarLookup,+ Message(Message),+ MessageType(SyntaxError),+ StateC,+ ScadOpts(ScadOpts),+ CompState(CompState, scadVars, messages),+ SourcePosition(SourcePosition),+ OVal(OUndefined),+ varUnion+ )++import Graphics.Implicit.ExtOpenScad.Util.StateC (modifyVarLookup, addMessage)++import Graphics.Implicit.ExtOpenScad.Parser.Expr (expr0)++import Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, matchPat, rawRunExpr)++import Graphics.Implicit.ExtOpenScad.Default (defaultObjects)++import "monads-tf" Control.Monad.State (liftIO, runStateT, (>>=))++import System.Directory (getCurrentDirectory)++import Text.Parsec (SourceName, parse, ParseError)++import Text.Parsec.Error (errorMessages, showErrorMessages)++import Graphics.Implicit.ExtOpenScad.Parser.Util (patternMatcher)++import Graphics.Implicit.ExtOpenScad.Parser.Lexer (matchTok)++-- | Define variables used during the extOpenScad run.+addConstants :: [String] -> IO (VarLookup, [Message])+addConstants constants = do+ path <- getCurrentDirectory+ (_, s) <- liftIO . runStateT (execAssignments constants) $ CompState defaultObjects [] path [] opts+ pure (scadVars s, messages s)+ where+ opts = ScadOpts False False+ show' = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . errorMessages+ execAssignments :: [String] -> StateC Fastℕ+ execAssignments = foldlM execAssignment 0+ execAssignment :: Fastℕ -> String -> StateC Fastℕ+ execAssignment count assignment = do+ let pos = SourcePosition count 1 "cmdline_constants"+ err = addMessage SyntaxError pos . show'+ run (k, e) = evalExpr pos e >>= traverse_ (modifyVarLookup . varUnion) . matchPat k+ either err run $ parseAssignment "cmdline_constant" assignment+ pure $ count + 1+ parseAssignment :: SourceName -> String -> Either ParseError (Pattern, Expr)+ parseAssignment = parse $ (,) <$> patternMatcher <* matchTok '=' <*> expr0++-- | Evaluate an expression.+runExpr :: String -> (OVal, [Message])+runExpr expression = do+ either oUndefined run $ parse expr0 "raw_expression" expression+ where+ run expr = rawRunExpr initPos defaultObjects expr+ initPos = SourcePosition 1 1 "raw_expression"+ show' = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . errorMessages+ oUndefined e = (OUndefined, [Message SyntaxError initPos $ show' e])
Graphics/Implicit/ExtOpenScad/Eval/Expr.hs view
@@ -2,102 +2,142 @@ -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE -module Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, matchPat) where+-- allow us to specify what package to import what module from.+-- We don't actually care, but when we compile our haskell examples, we do.+{-# LANGUAGE PackageImports #-} -import Prelude (String, Maybe(Just, Nothing), IO, concat, ($), map, return, zip, (!!), const, (++), foldr, concatMap)+module Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, rawRunExpr, matchPat, StateE, ExprState(ExprState), messages, addMessage) where +import Prelude (String, Maybe(Just, Nothing), ($), fmap, pure, zip, (!!), const, (<>), foldr, foldMap, (.), (<$>), traverse)+ import Graphics.Implicit.ExtOpenScad.Definitions ( Pattern(Name, ListP, Wild),- OVal(OList, OError, OFunc),- Expr(LitE, Var, ListE, LamE, (:$)),- VarLookup)+ OVal(OList, OError, OFunc, OUndefined),+ Expr(LitE, ListE, LamE, Var, (:$)),+ Symbol(Symbol),+ VarLookup(VarLookup),+ SourcePosition,+ Message(Message),+ MessageType(Error),+ StateC+ ) import Graphics.Implicit.ExtOpenScad.Util.OVal (oTypeStr, getErrors)-import Graphics.Implicit.ExtOpenScad.Util.StateC (StateC, getVarLookup) +import Graphics.Implicit.ExtOpenScad.Util.StateC (getVarLookup)++import qualified Graphics.Implicit.ExtOpenScad.Util.StateC as GIEUS (addMessage)+ 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)+import Data.Foldable (fold, traverse_) +import Data.Functor.Identity (Identity)++import Data.Traversable (for)++import Control.Monad (zipWithM)++import "monads-tf" Control.Monad.State (StateT, get, modify, runState)++data ExprState = ExprState+ { _scadVars :: VarLookup+ , patterns :: [String]+ , messages :: [Message]+ , _sourcePos :: SourcePosition+ }++type StateE = StateT ExprState Identity++-- Add a message to our list of messages contained in the StatE monad.+addMessage :: MessageType -> SourcePosition -> String -> StateE ()+addMessage mtype pos text = addMesg $ Message mtype pos text+ where+ addMesg :: Message -> StateE ()+ addMesg m = modify $ \s -> s { messages = messages s <> pure m }++-- Log an error condition.+errorE :: SourcePosition -> String -> StateE ()+errorE = addMessage Error++-- | The names of all of the patterns in the given pattern. patVars :: Pattern -> [String]-patVars (Name name) = [name]-patVars (ListP pats) = concatMap patVars pats-patVars _ = []+patVars (Name (Symbol name)) = [name]+patVars (ListP pats) = foldMap patVars pats+patVars Wild = [] +-- | Match patterns and ovals, returning a list of all of the OVals matched. patMatch :: Pattern -> OVal -> Maybe [OVal] patMatch (Name _) val = Just [val]-patMatch (ListP pats) (OList vals) = do- matches <- zipWithM patMatch pats vals- return $ concat matches+patMatch (ListP pats) (OList vals) = fold <$> zipWithM patMatch pats vals patMatch Wild _ = Just [] patMatch _ _ = Nothing +-- | Construct a VarLookup from the given Pattern and OVal, if possible. matchPat :: Pattern -> OVal -> Maybe VarLookup-matchPat pat val = do- let vars = patVars pat- vals <- patMatch pat val- return $ fromList $ zip vars vals+matchPat pat val = VarLookup . fromList . zip (Symbol <$> patVars pat) <$> patMatch pat val -evalExpr :: Expr -> StateC OVal-evalExpr expr = do- varlookup <- getVarLookup- (valf, _) <- liftIO $ runStateT (evalExpr' expr) (varlookup, [])- return $ valf []+-- | The entry point from StateC. evaluates an expression, pureing the result, and moving any error messages generated into the calling StateC.+evalExpr :: SourcePosition -> Expr -> StateC OVal+evalExpr pos expr = do+ vars <- getVarLookup+ let+ (valf, s) = runState (evalExpr' expr) $ ExprState vars [] [] pos+ moveMessage (Message mtype mpos text) = GIEUS.addMessage mtype mpos text+ traverse_ moveMessage $ messages s+ pure $ valf [] -evalExpr' :: Expr -> StateT (VarLookup, [String]) IO ([OVal] -> OVal)+-- A more raw entry point, that does not depend on IO.+rawRunExpr :: SourcePosition -> VarLookup -> Expr -> (OVal, [Message])+rawRunExpr pos vars expr = do+ let+ (valf, s) = runState (evalExpr' expr) $ ExprState vars [] [] pos+ (valf [], messages s) -evalExpr' (Var name ) = do- (varlookup, namestack) <- get- return $- case (lookup name varlookup, elemIndex name namestack) of- (_, Just pos) -> (!! pos)- (Just val, _) -> const val- _ -> const $ OError ["Variable " ++ name ++ " not in scope" ]+-- The expression evaluators.+evalExpr' :: Expr -> StateE ([OVal] -> OVal) -evalExpr' (LitE val ) = return $ const val+-- Evaluate a variable lookup.+evalExpr' (Var (Symbol name)) = do+ (ExprState (VarLookup varlookup) namestack _ spos) <- get+ case (lookup (Symbol name) varlookup, elemIndex name namestack) of+ (_, Just pos) -> pure (!! pos)+ (Just val, _) -> pure $ const val+ _ -> do+ errorE spos ("Variable " <> name <> " not in scope")+ pure $ const OUndefined +-- Evaluate a literal value.+evalExpr' (LitE val) = pure $ const val++-- Evaluate a list of expressions. evalExpr' (ListE exprs) = do- valFuncs <- mapM evalExpr' exprs- return $ \s -> OList $ map ($s) valFuncs+ valFuncs <- traverse evalExpr' exprs+ pure $ \s -> OList $ ($s) <$> valFuncs +-- Evaluate application of a function. evalExpr' (fexpr :$ argExprs) = do fValFunc <- evalExpr' fexpr- argValFuncs <- mapM evalExpr' argExprs- return $ \s -> app (fValFunc s) (map ($s) argValFuncs)+ argValFuncs <- traverse evalExpr' argExprs+ pure $ \s -> app (fValFunc s) (fmap ($s) argValFuncs) where app f l = case (getErrors f, getErrors $ OList l) of (Nothing, Nothing) -> app' f l where app' (OFunc f') (x:xs) = app (f' x) xs app' a [] = a- app' x _ = OError ["Can't apply arguments to " ++ oTypeStr x]+ app' x _ = OError ["Can't apply arguments to " <> oTypeStr x] (Just err, _ ) -> OError [err] (_, Just err) -> OError [err] +-- Evaluate a lambda function. evalExpr' (LamE pats fexpr) = do- fparts <- forM pats $ \pat -> do- modify (second (patVars pat ++))- return $ \f xss -> OFunc $ \val -> case patMatch pat val of- Just xs -> f (xs ++ xss)+ fparts <- for pats $ \pat -> do+ modify $ \s -> s { patterns = patVars pat <> patterns s}+ pure $ \f xss -> OFunc $ \val -> case patMatch pat val of+ Just xs -> f (xs <> xss) Nothing -> OError ["Pattern match failed"] fval <- evalExpr' fexpr- return $ foldr ($) fval fparts-----------------+ pure $ foldr ($) fval fparts -{--simplifyExpr ((simplifyExpr -> Var f) :$ args) = (Var f :$) $- let- split b l = (filter b l, filter (not.b) l)- args' = map simplifyExpr args- (numArgs, nonNumArgs) = split (\x -> case x of LitE (ONum n) -> True; _ -> False) args'- numArgs' = map (\(LitE (ONum n)) -> n) numArgs- in case f of- "+" -> (LitE $ ONum $ sum numArgs'):nonNumArgs- "*" -> (LitE $ ONum $ product numArgs'):nonNumArgs- _ -> args'-simplifyExpr x = x--}
Graphics/Implicit/ExtOpenScad/Eval/Statement.hs view
@@ -2,152 +2,279 @@ -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE -{-# LANGUAGE ScopedTypeVariables #-}+-- allow us to specify what package to import what module from.+-- We don't actually care, but when we compile our haskell examples, we do.+{-# LANGUAGE PackageImports #-} 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)+import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left, Right), (.), ($), show, pure, (<>), reverse, fst, snd, readFile, filter, length, (&&), (==), (/=), fmap, notElem, elem, not, zip, init, last, null, String, (*>), (<$>), traverse, (<$)) import Graphics.Implicit.ExtOpenScad.Definitions (- Statement(Include, (:=), Echo, For, If, NewModule, ModuleCall, DoNothing),+ Statement(Include, (:=), If, NewModule, ModuleCall, DoNothing), Pattern(Name), Expr(LitE),- OVal(OString, OBool, OList, OModule),- VarLookup,- StatementI(StatementI)+ OVal(OBool, OUModule, ONModule, OVargsModule),+ VarLookup(VarLookup),+ StatementI(StatementI),+ Symbol(Symbol),+ Message(Message),+ ScadOpts(importsAllowed),+ StateC,+ CompState(CompState, messages, sourceDir, scadOpts),+ varUnion ) import Graphics.Implicit.ExtOpenScad.Util.OVal (getErrors) import Graphics.Implicit.ExtOpenScad.Util.ArgParser (argument, defaultTo, argMap)-import Graphics.Implicit.ExtOpenScad.Util.StateC (StateC, errorC, modifyVarLookup, mapMaybeM, lookupVar, pushVals, getRelPath, withPathShiftedBy, getVals, putVals)+import Graphics.Implicit.ExtOpenScad.Util.StateC (errorC, warnC, modifyVarLookup, scadOptions, lookupVar, pushVals, getRelPath, withPathShiftedBy, getVals, putVals, addMessage, getVarLookup) 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 Control.Monad (forM_, forM, mapM_) -import Control.Monad.State (get, liftIO, mapM, runStateT, (>>))-import qualified System.FilePath as FilePath+import Data.List (intercalate) +import Data.Map (union, fromList, toList)++import Data.Maybe (isJust, fromMaybe, mapMaybe, catMaybes)++import Control.Monad (when, unless, (>>=))++import "monads-tf" Control.Monad.State (gets, liftIO, runStateT)++import Data.Foldable (traverse_, for_)++import Data.Traversable (for)++import System.FilePath (takeDirectory)+ -- Run statements out of the OpenScad file. runStatementI :: StatementI -> StateC () -runStatementI (StatementI lineN (pat := expr)) = do- val <- evalExpr expr+-- | Interpret variable assignment+runStatementI (StatementI sourcePos (pat := expr)) = do+ val <- evalExpr sourcePos expr let posMatch = matchPat pat val case (getErrors val, posMatch) of- (Just err, _ ) -> errorC lineN err- (_, Just match) -> modifyVarLookup $ Map.union match- (_, Nothing ) -> errorC lineN "pattern match failed in assignment"--runStatementI (StatementI lineN (Echo exprs)) = do- let- show2 (OString s) = s- show2 x = show x- vals <- mapM evalExpr exprs- case getErrors (OList vals) of- Nothing -> liftIO . putStrLn $ concatMap show2 vals- Just err -> errorC lineN err--runStatementI (StatementI lineN (For pat expr loopContent)) = do- val <- evalExpr expr- case (getErrors val, val) of- (Just err, _) -> errorC lineN err- (_, OList vals) -> forM_ vals $ \v ->- case matchPat pat v of- Just match -> do- modifyVarLookup $ Map.union match- runSuite loopContent- Nothing -> return ()- _ -> return ()+ (Just err, _ ) -> errorC sourcePos err+ (_, Just (VarLookup match)) ->+ for_ (toList match) $ \(Symbol varName, _) -> do+ maybeVar <- lookupVar (Symbol varName)+ when (isJust maybeVar)+ (warnC sourcePos $ "redefining already defined object: " <> show varName)+ modifyVarLookup $ varUnion (VarLookup match)+ (_, Nothing ) -> errorC sourcePos "pattern match failed in assignment" -runStatementI (StatementI lineN (If expr a b)) = do- val <- evalExpr expr+-- | Interpret an if conditional statement.+runStatementI (StatementI sourcePos (If expr a b)) = do+ val <- evalExpr sourcePos expr case (getErrors val, val) of- (Just err, _ ) -> errorC lineN ("In conditional expression of if statement: " ++ err)+ (Just err, _ ) -> errorC sourcePos ("In conditional expression of if statement: " <> err) (_, OBool True ) -> runSuite a (_, OBool False) -> runSuite b- _ -> return ()+ _ -> pure () -runStatementI (StatementI lineN (NewModule name argTemplate suite)) = do- argTemplate' <- forM argTemplate $ \(name', defexpr) -> do- defval <- mapMaybeM evalExpr defexpr- return (name', defval)- (varlookup, _, path, _, _) <- get+-- | Interpret a module declaration.+runStatementI (StatementI sourcePos (NewModule name argTemplate suite)) = do+ argTemplate' <- for argTemplate $ \(argName, defexpr) -> do+ defval <- traverse (evalExpr sourcePos) defexpr+ pure (argName, defval)+ argNames <- for argTemplate $ \(argName, defexpr) -> do+ defval <- traverse (evalExpr sourcePos) defexpr+ let+ hasDefault = isJust defval+ pure (argName, hasDefault)+ (VarLookup varlookup) <- getVarLookup -- FIXME: \_? really?- runStatementI . StatementI lineN $ (Name name :=) $ LitE $ OModule $ \_ -> do- newNameVals <- forM argTemplate' $ \(name', maybeDef) -> do+ runStatementI . StatementI sourcePos $ (Name name :=) $ LitE $ OUModule name (Just argNames) $ \_ -> do+ newNameVals <- for argTemplate' $ \(argName, maybeDef) -> do val <- case maybeDef of- Just def -> argument name' `defaultTo` def- Nothing -> argument name'- return (name', val)+ Just def -> argument argName `defaultTo` def+ Nothing -> argument argName+ pure (argName, val) let-{-- children = ONum $ fromIntegral $ length vals- child = OModule $ \vals -> do- n :: ℕ <- argument "n";- return $ return $ return $- if n <= length vals- then vals !! n- else OUndefined- childBox = OFunc $ \n -> case fromOObj n :: Maybe ℕ of- Just n | n < length vals -> case vals !! n of- -- _ -> toOObj $ getBox3 obj3- -- _ -> toOObj $ getBox2 obj2- _ -> OUndefined- _ -> OUndefined- newNameVals' = newNameVals ++ [("children", children),("child", child), ("childBox", childBox)]--}- varlookup' = Map.union (Map.fromList newNameVals) varlookup- suiteVals = runSuiteCapture varlookup' path suite- return suiteVals+ varlookup' = union (fromList newNameVals) varlookup+ pure $ runSuiteCapture (VarLookup varlookup') suite -runStatementI (StatementI lineN (ModuleCall name argsExpr suite)) = do- maybeMod <- lookupVar name- (varlookup, _, path, _, _) <- get- childVals <- fmap reverse . liftIO $ runSuiteCapture varlookup path suite- 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 = fromMaybe (return []) (fst $ argMap argsVal argparser)- Just foo -> do+-- | Interpret a call to a module.+runStatementI (StatementI sourcePos (ModuleCall (Symbol name) argsExpr suite)) = do+ maybeMod <- lookupVar (Symbol name)+ varlookup <- getVarLookup+ newVals <- case maybeMod of+ Just (OUModule _ args mod') -> do+ optionsMatch <- checkOptions args True+ unless optionsMatch (errorC sourcePos $ "Options check failed when executing user-defined module " <> name <> ".")+ evaluatedArgs <- evalArgs argsExpr+ -- Evaluate the suite.+ suiteResults <- runSuiteCapture varlookup suite+ when (suite /= []) (errorC sourcePos $ "Suite provided, but module " <> name <> " does not accept one. Perhaps a missing semicolon?")+ -- Run the module.+ let+ argsMapped = argMap evaluatedArgs $ mod' suiteResults+ for_ (snd argsMapped) $ errorC sourcePos+ fromMaybe (pure []) (fst argsMapped)+ Just (ONModule _ implementation forms) -> do+ possibleInstances <- selectInstances forms+ let+ suiteInfo = case possibleInstances of+ [(_, suiteInfoFound)] -> suiteInfoFound+ [] -> Nothing+ ((_, suiteInfoFound):_) -> suiteInfoFound+ when (null possibleInstances) (do+ errorC sourcePos $ "no instance of " <> name <> " found to match given parameters.\nInstances available:\n" <> show (ONModule (Symbol name) implementation forms)+ traverse_ (`checkOptions` True) $ fmap (Just . fst) forms+ )+ -- Ignore this for now, because all instances we define have the same suite requirements.+ {-+ when (length possibleInstances > 1) (do+ errorC sourcePos $ "too many instances of " <> name <> " have been found that match given parameters."+ traverse_ (`checkOptions` True) $ fmap (Just . fst) possibleInstances)+ -}+ -- Evaluate all of the arguments.+ evaluatedArgs <- evalArgs argsExpr+ -- Evaluate the suite.+ vals <- runSuiteCapture varlookup suite+ suiteResults <- case suiteInfo of+ Just True -> do+ when (null vals) (errorC sourcePos "Suite required, but none provided.")+ pure vals+ Just False -> pure vals+ _ -> do+ when (suite /= []) (errorC sourcePos $ "Suite provided, but module " <> name <> " does not accept one. Perhaps a missing semicolon?")+ pure []+ -- Run the module.+ let+ argsMapped = argMap evaluatedArgs $ implementation sourcePos suiteResults+ for_ (snd argsMapped) $ errorC sourcePos+ fromMaybe (pure []) (fst argsMapped)+ Just (OVargsModule modname mod') -> do+ -- Evaluate all of the arguments.+ evaluatedArgs <- evalArgs argsExpr+ -- Run the module, which evaluates it's own suite.+ _ <- mod' modname sourcePos evaluatedArgs suite runSuite -- no values are pureed+ pure []+ Just foo -> do case getErrors foo of- Just err -> errorC lineN err- Nothing -> errorC lineN "Object called not module!"- return []- Nothing -> do- errorC lineN $ "Module " ++ name ++ " not in scope."- return []+ Just err -> errorC sourcePos err+ Nothing -> errorC sourcePos $ "Object " <> name <> " is not a module!"+ pure []+ _ -> do+ errorC sourcePos $ "Module " <> name <> " not in scope."+ pure [] pushVals newVals+ where+ selectInstances :: [([(Symbol, Bool)], Maybe Bool)] -> StateC [([(Symbol, Bool)], Maybe Bool)]+ selectInstances instances = do+ validInstances <- for instances+ ( \(args, suiteInfo) -> do+ res <- checkOptions (Just args) False+ pure $ if res then Just (args, suiteInfo) else Nothing+ )+ pure $ catMaybes validInstances+ checkOptions :: Maybe [(Symbol, Bool)] -> Bool -> StateC Bool+ checkOptions args makeWarnings = do+ let+ -- Find what arguments are satisfied by a default value, were given in a named parameter, or were given.. and count them.+ valDefaulted ,valNotDefaulted, valNamed, mappedDefaulted, mappedNotDefaulted, notMappedNotDefaultable :: [Symbol]+ -- function definition has a default value.+ valDefaulted = fmap fst $ filter snd $ fromMaybe [] args+ -- function definition has no default value.+ valNotDefaulted = fmap fst $ filter (not.snd) $ fromMaybe [] args+ -- function call has a named expression bound to this symbol.+ valNamed = namedParameters argsExpr+ -- function call has a named expression, function definition has an argument with this name, AND there is a default value for this argument.+ mappedDefaulted = filter (`elem` valNamed) valDefaulted+ -- function call has a named expression, function definition has an argument with this name, AND there is NOT a default value for this argument.+ mappedNotDefaulted = filter (`elem` valNamed) valNotDefaulted+ -- arguments we need to find a mapping for, from the unnamed expressions.+ notMappedNotDefaultable = filter (`notElem` mappedNotDefaulted) valNotDefaulted+ -- expressions without a name.+ valUnnamed :: [Expr]+ valUnnamed = unnamedParameters argsExpr+ mapFromUnnamed :: [(Symbol, Expr)]+ mapFromUnnamed = zip notMappedNotDefaultable valUnnamed+ missingNotDefaultable = filter (`notElem` (mappedDefaulted <> mappedNotDefaulted <> fmap fst mapFromUnnamed)) valNotDefaulted+ extraUnnamed = filter (`notElem` (valDefaulted <> valNotDefaulted)) $ namedParameters argsExpr+ parameterReport = "Passed " <>+ (if null valNamed && null valUnnamed then "no parameters" else "" ) <>+ (if not (null valNamed) then show (length valNamed) <> (if length valNamed == 1 then " named parameter" else " named parameters") else "" ) <>+ (if not (null valNamed) && not (null valUnnamed) then ", and " else "") <>+ (if not (null valUnnamed) then show (length valUnnamed) <> (if length valUnnamed == 1 then " un-named parameter." else " un-named parameters.") else ".") <>+ (if not (null missingNotDefaultable) then+ (if length missingNotDefaultable == 1+ then " Couldn't match one parameter: " <> showSymbol (last missingNotDefaultable)+ else " Couldn't match " <> show (length missingNotDefaultable) <> " parameters: " <> intercalate ", " (showSymbol <$> init missingNotDefaultable) <> " and " <> showSymbol (last missingNotDefaultable) <> "."+ ) else "") <>+ (if not (null extraUnnamed) then+ (if length extraUnnamed == 1+ then " Had one extra parameter: " <> showSymbol (last extraUnnamed)+ else " Had " <> show (length extraUnnamed) <> " extra parameters. They are:" <> intercalate ", " (showSymbol <$> init extraUnnamed) <> " and " <> showSymbol (last extraUnnamed) <> "."+ ) else "")+ showSymbol :: Symbol -> String+ showSymbol (Symbol sym) = show sym+ {-+ when (makeWarnings)+ (errorC sourcePos $ foldMap show argsExpr)+ when (makeWarnings)+ (errorC sourcePos $ "valNamed: " <> show (length valNamed))+ when (makeWarnings)+ (errorC sourcePos $ "mappedDefaulted: " <> show (length mappedDefaulted))+ when (makeWarnings)+ (errorC sourcePos $ "mappedNotDefaulted: " <> show (length mappedNotDefaulted))+ when (makeWarnings)+ (errorC sourcePos $ "notMappedNotDefaultable: " <> show (length notMappedNotDefaultable))+ when (makeWarnings)+ (errorC sourcePos $ "mapFromUnnamed: " <> show (length mapFromUnnamed))+ when (makeWarnings)+ (errorC sourcePos $ "missingNotDefaultable: " <> show (length missingNotDefaultable))+ -}+ when (not (null missingNotDefaultable) && makeWarnings)+ (errorC sourcePos $ "Insufficient parameters. " <> parameterReport)+ when (not (null extraUnnamed) && isJust args && makeWarnings)+ (errorC sourcePos $ "Too many parameters: " <> show (length extraUnnamed) <> " extra. " <> parameterReport)+ pure $ null missingNotDefaultable && null extraUnnamed+ namedParameters :: [(Maybe Symbol, Expr)] -> [Symbol]+ namedParameters = mapMaybe fst+ unnamedParameters :: [(Maybe Symbol, Expr)] -> [Expr]+ unnamedParameters = mapMaybe (+ \(argName, expr) ->+ case argName of+ Just _ -> Nothing+ Nothing -> Just expr+ )+ evalArgs :: [(Maybe Symbol, Expr)] -> StateC [(Maybe Symbol, OVal)]+ evalArgs args = for args $ \(posName, expr) -> do+ val <- evalExpr sourcePos expr+ pure (posName, val) -runStatementI (StatementI _ (Include name injectVals)) = do- name' <- getRelPath name- content <- liftIO $ readFile name'- case parseProgram content of- Left e -> liftIO $ putStrLn $ "Error parsing " ++ name ++ ":" ++ show e- Right sts -> withPathShiftedBy (FilePath.takeDirectory name) $ do+-- | Interpret an include or use statement.+runStatementI (StatementI sourcePos (Include name injectVals)) = do+ opts <- scadOptions+ if importsAllowed opts+ then do+ name' <- getRelPath name+ content <- liftIO $ readFile name'+ case parseProgram name' content of+ Left e -> errorC sourcePos $ "Error parsing " <> name <> ":" <> show e+ Right sts -> withPathShiftedBy (takeDirectory name) $ do vals <- getVals putVals [] runSuite sts- vals' <- getVals- if injectVals then putVals (vals' ++ vals) else putVals vals+ if injectVals+ then do+ vals' <- getVals+ putVals $ vals' <> vals+ else putVals vals+ else warnC sourcePos $ "Not importing " <> name <> ": File import disabled." -runStatementI (StatementI _ DoNothing) = liftIO $ putStrLn "Do Nothing?"+runStatementI (StatementI _ DoNothing) = pure () runSuite :: [StatementI] -> StateC ()-runSuite = mapM_ runStatementI--runSuiteCapture :: VarLookup -> FilePath -> [StatementI] -> IO [OVal]-runSuiteCapture varlookup path suite = do- (res, _) <- runStateT- (runSuite suite >> getVals)- (varlookup, [], path, (), () )- return res---+runSuite = traverse_ runStatementI +runSuiteCapture :: VarLookup -> [StatementI] -> StateC [OVal]+runSuiteCapture varlookup suite = do+ (res, s) <- gets mkSubState >>= liftIO . runStateT (runSuite suite *> getVals)+ reverse res <$ traverse moveMessage (messages s)+ where+ mkSubState s = CompState varlookup [] (sourceDir s) [] (scadOpts s)+ moveMessage (Message mtype mpos text) = addMessage mtype mpos text
Graphics/Implicit/ExtOpenScad/Parser/Expr.hs view
@@ -1,278 +1,182 @@ -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)--- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)+-- Copyright (C) 2014-2019 , Julia Longtin (julial@turinglace.com)+-- Copyright (C) 2016, Kelvin Cookshaw (kelvin@cookshaw.com) -- Released under the GNU AGPLV3+, see LICENSE --- a parser for a numeric expression.+-- Allow us to use shorter forms of Var and Name.+{-# LANGUAGE PatternSynonyms #-}++-- A parser for a numeric expressions. 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), String, ($), (<>), id, foldl, foldr, (==), length, head, (&&), (<$>), (<*>), (*>), (<*), flip, (.), pure) --- the datatype representing the graininess of our world.-import Graphics.Implicit.Definitions (ℝ)+import Graphics.Implicit.ExtOpenScad.Definitions (Expr(LamE, LitE, ListE, (:$)), OVal(ONum, OUndefined), Symbol(Symbol)) --- The parsec parsing library.-import Text.ParserCombinators.Parsec (GenParser, string, many1, digit, char, many, noneOf, sepBy, sepBy1, optionMaybe, try)+import qualified Graphics.Implicit.ExtOpenScad.Definitions as GIED (Expr(Var), Pattern(Name)) -import Graphics.Implicit.ExtOpenScad.Definitions (Expr(Var, LitE, ListE, (:$)), OVal(ONum, OString, OBool, OUndefined), collector) +import Graphics.Implicit.ExtOpenScad.Parser.Util ((?:), (*<|>), number, boolean, scadString, scadUndefined, variable) -import Graphics.Implicit.ExtOpenScad.Parser.Util (variableSymb, (?:), (*<|>), genSpace, padString)+-- The lexer.+import Graphics.Implicit.ExtOpenScad.Parser.Lexer (whiteSpace, matchLet, matchTok, matchColon, matchComma, surroundedBy, matchIdentifier, matchEQ, matchNE, matchLE, matchLT, matchGE, matchGT, matchCAT, matchAND, matchOR) -variable :: GenParser Char st Expr-variable = fmap Var variableSymb+-- The parsec parsing library.+import Text.Parsec (oneOf, many, sepBy, optionMaybe, option, (<|>), chainl1, chainr1) -literal :: GenParser Char st Expr-literal = ("literal" ?:) $- "boolean" ?: do- b <- (string "true" >> return True )- *<|> (string "false" >> return False)- return . LitE $ OBool b- -- FIXME: this is a hack, implement something like exprN to replace this?- *<|> "number" ?: (- 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- _ <- char 'e'- 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 '.'- 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 "\""- strlit <- many $ (string "\\\"" >> return '\"')- *<|> (string "\\n" >> return '\n')- *<|> (string "\\r" >> return '\r')- *<|> (string "\\t" >> return '\t')- *<|> (string "\\\\" >> return '\\')- -- FIXME: no \u unicode support?- *<|> noneOf "\"\n"- _ <- string "\""- return . LitE $ OString strlit+import Text.Parsec.String (GenParser) --- We represent the priority or 'fixity' of different types of expressions--- by the ExprIdx argument, with A0 as the highest.+import Control.Monad.Fix(fix) +-- Let us use the old syntax when defining Vars and Names.+pattern Var :: String -> Expr+pattern Var s = GIED.Var (Symbol s)+pattern Name :: String -> GIED.Pattern+pattern Name n = GIED.Name (Symbol n)++-- Borrowed the pattern from http://compgroups.net/comp.lang.functional/parsing-ternary-operator-with-parsec/1052460+-- In the levels list, the first element is the lowest precedent, and the last is the highest.+-- "higher" represents the higher precedence parser, ie. the next one in the levels list.+-- "fix $ \self ->..." is used to consume all expressions in the same level, "self" being the current level. expr0 :: GenParser Char st Expr-expr0 = exprN A0+expr0 = foldr ($) nonAssociativeExpr levels+ where+ levels :: [GenParser Char st Expr -> GenParser Char st Expr]+ levels =+ [ id+ , \higher -> fix $ \self -> do -- ?: ternary operator.+ condition <- higher+ do+ trueExpr <- matchTok '?' *> self+ falseExpr <- matchColon *> self+ pure $ Var "?" :$ [condition, trueExpr, falseExpr]+ <|>+ pure condition+ , \higher -> -- || boolean OR operator+ chainl1 higher $ binaryOperation <$> matchOR+ , \higher -> -- && boolean AND operator+ chainl1 higher $ binaryOperation <$> matchAND+ , \higher -> -- == and != operators+ chainl1 higher $ binaryOperation <$> (matchEQ <|> matchNE)+ , \higher -> -- <, <=, >= and > operators+ chainl1 higher $ binaryOperation <$> (matchLE <|> matchLT <|> matchGE <|> matchGT)+ , \higher -> -- + and - operators+ chainl1 higher $ binaryOperation . pure <$> oneOf "+-" <* whiteSpace+ , \higher -> -- ++ string/list concatenation operator. This is not available in OpenSCAD.+ chainl1 higher $ binaryOperation <$> matchCAT+ , \higher -> -- ^ exponent operator. This is not available in OpenSCAD.+ chainr1 higher $ binaryOperation <$> matchTok '^'+ , \higher -> -- *, /, % operators+ chainl1 higher $ binaryOperation . pure <$> oneOf "*/%" <* whiteSpace+ , \higher ->+ fix $ \self -> -- unary ! operator. OpenSCAD's YACC parser puts '!' at the same level of precedence as '-' and '+'.+ do+ op <- matchTok '!'+ right <- self+ -- when noting a not, just skip both of them.+ pure $ case right of+ Var "!" :$ [deepright] -> deepright+ _ -> Var op :$ [right]+ <|>+ higher+ , \higher -> -- leading positive or negative sign.+ fix $ \self ->+ do -- Unary -. applied to strings is undefined, but handle that in the interpreter.+ right <- matchTok '-' *> self+ pure $ Var "negate" :$ [right]+ <|> do -- Unary +. Handle this by ignoring the ++ matchTok '+' *> self+ <|>+ higher+ , \higher -> -- "let" expression+ flip (foldr bindLets) <$> (matchLet *> surroundedBy '(' (assignment `sepBy` matchTok ',') ')') <*> expr0+ <|>+ higher+ ] --- what state in the expression parser tree we are inside of.-data ExprIdx = A0 | A1 | A2 | A3 | A4 | A5 | A6 | A7 | A8 | A9 | A10 | A11 | A12+-- | parse expressions that don't associate, either because they are not operators or because they are operators+-- that contain the expressions they operate on in start and end tokens, like parentheses, and no other operator can associate with their expressions.+nonAssociativeExpr :: GenParser Char st Expr+nonAssociativeExpr =+ number+ <|> vectorListParentheses+ <|> variableish+ <|> scadString+ <|> boolean+ <|> scadUndefined -exprN :: ExprIdx -> GenParser Char st Expr+-- | parse operations that start with a variable name,+-- including variable reference, function calling, variable list indexing, and variable list splicing.+variableish :: GenParser Char st Expr+variableish = "variable" ?:+ do+ obj <- variable+ args <- option [] (+ "function application" ?: do+ args <- surroundedBy '(' (sepBy expr0 matchComma) ')'+ pure [(:$ args)]+ )+ mods <- many (+ "list indexing" ?: do+ i <- surroundedBy '[' expr0 ']'+ pure $ \l -> Var "index" :$ [l, i]+ *<|> "list splicing" ?: do+ start <- matchTok '[' *> optionMaybe expr0+ end <- matchColon *> optionMaybe expr0 <* matchTok ']'+ pure $ case (start, end) of+ (Nothing, Nothing) -> id+ (Just s, Nothing) -> \l -> Var "splice" :$ [l, s, LitE OUndefined]+ (Nothing, Just e ) -> \l -> Var "splice" :$ [l, LitE $ ONum 0, e]+ (Just s, Just e ) -> \l -> Var "splice" :$ [l, s, e]+ )+ pure $ foldl (\a b -> b a) obj (args <> mods) -exprN A12 =- literal- *<|> variable- *<|> "bracketed expression" ?: do- -- eg. ( 1 + 5 )- _ <- string "("- expr <- expr0- _ <- string ")"- return expr- *<|> "vector/list" ?: (- do- -- eg. [ 3, a, a+1, b, a*b ]- _ <- string "["- exprs <- sepBy expr0 (char ',' )- _ <- string "]"- return $ ListE exprs- *<|> do- -- eg. ( 1,2,3 )- _ <- string "("- exprs <- sepBy expr0 (char ',' )- _ <- string ")"- return $ ListE exprs- )+-- | Parse parentheses, lists, vectors, and vector/list generators.+vectorListParentheses :: GenParser Char st Expr+vectorListParentheses =+ "vector/list/parentheses" ?: do+ -- eg. [ 3, a, a+1, b, a*b] - list+ -- ( 1, 2, 3) - list+ -- (a+1) - parenthesized expression.+ o <- oneOf "[(" <* whiteSpace+ exprs <- sepBy expr0 matchComma+ <* if o == '['+ then matchTok ']'+ else matchTok ')'+ pure $ if o == '(' && length exprs == 1+ then head exprs+ else ListE exprs *<|> "vector/list generator" ?: do -- eg. [ a : 1 : a + 10 ]- _ <- string "["- exprs <- sepBy expr0 (char ':' )- _ <- string "]"- return $ collector "list_gen" exprs--exprN A11 =- do- obj <- exprN A12- _ <- genSpace- mods <- many1 (- "function application" ?: do- _ <- padString "("- args <- sepBy expr0 (padString ",")- _ <- padString ")"- return $ \f -> f :$ args- *<|> "list indexing" ?: do- _ <- padString "["- i <- expr0- _ <- padString "]"- return $ \l -> Var "index" :$ [l, i]- *<|> "list splicing" ?: do- _ <- padString "["- start <- optionMaybe expr0- _ <- padString ":"- end <- optionMaybe expr0- _ <- padString "]"- return $ case (start, end) of- (Nothing, Nothing) -> id- (Just s, Nothing) -> \l -> Var "splice" :$ [l, s, LitE OUndefined ]- (Nothing, Just e ) -> \l -> Var "splice" :$ [l, LitE $ ONum 0, e]- (Just s, Just e ) -> \l -> Var "splice" :$ [l, s, e]- )- return $ foldl (\a b -> b a) obj mods- *<|> exprN A12---- match a leading (+) or (-) operator.-exprN A10 =- "negation" ?: do- _ <- padString "-"- expr <- exprN A11- return $ Var "negate" :$ [expr]- *<|> do- _ <- padString "+"- exprN A11- *<|> exprN A11---- match power-of (^) operator.-exprN A9 =- "exponentiation" ?: do- a <- exprN A10- _ <- padString "^"- b <- exprN A9- return $ Var "^" :$ [a,b]- *<|> 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 "/" ))- (try $ padString "*" )- let div' a b = Var "/" :$ [a, b]- return . collector "*" $ map (foldl1 div') exprs- *<|> exprN A9---- match remainder (%) operator.-exprN A7 =- "modulo" ?: do- exprs <- sepBy1 (exprN A8) (try $ padString "%")- let mod' a b = Var "%" :$ [a, b]- return $ foldl1 mod' exprs- *<|> exprN A8---- match string addition (++) operator.-exprN A6 =- "append" ?: do- exprs <- sepBy1 (exprN A7) (try $ padString "++")- return $ collector "++" exprs- *<|> 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 "-" ))- (try $ padString "+" )- let sub a b = Var "-" :$ [a, b]- return . collector "+" $ map (foldl1 sub) exprs- *<|> exprN A6---- match comparison operators.-exprN A4 =- do- firstExpr <- exprN A5- otherComparisonsExpr <- many $ do- comparisonSymb <-- padString "=="- *<|> padString "!="- *<|> padString ">="- *<|> padString "<="- *<|> padString ">"- *<|> padString "<"- expr <- exprN A5- return (Var comparisonSymb, expr)- let- (comparisons, otherExprs) = unzip otherComparisonsExpr- exprs = firstExpr:otherExprs- return $ case comparisons of- [] -> firstExpr- [x] -> x :$ exprs- _ -> collector "all" $ zipWith3 (\c e1 e2 -> c :$ [e1,e2]) comparisons exprs (tail exprs)- *<|> exprN A5---- match the logical negation operator.-exprN A3 =- "logical-not" ?: do- _ <- padString "!"- a <- exprN A4- return $ Var "!" :$ [a]- *<|> exprN A4+ -- [ a : a + 10 ]+ -- FIXME: clearly, these have a numeric context, and should fail to parse for non-numeric contents.+ expr1 <- matchTok '[' *> expr0 <* matchColon+ exprs <- do+ expr2 <- expr0+ expr3 <- optionMaybe (matchColon *> expr0)+ pure $ case expr3 of+ Just n -> [expr1, expr2, n]+ Nothing -> [expr1, LitE $ ONum 1.0, expr2]+ <* matchTok ']'+ pure $ collector "list_gen" exprs --- match the logical And and Or (&&,||) operators.-exprN A2 =- "logical and/or" ?: do- a <- exprN A3- symb <- padString "&&"- *<|> padString "||"- b <- exprN A2- return $ Var symb :$ [a,b]- *<|> exprN A3+-- | Apply a symbolic operator to a list of expressions, pureing one big expression.+-- Accepts a string for the operator, to simplify callers.+collector :: String -> [Expr] -> Expr+collector _ [x] = x+collector s l = Var s :$ [ListE l] --- match the ternary (1?2:3) operator.-exprN A1 =- "ternary" ?: do- a <- exprN A2- _ <- padString "?"- b <- exprN A1- _ <- padString ":"- c <- exprN A1- return $ Var "?" :$ [a,b,c]- *<|> exprN A2+-- | Apply a symbolic operator to two expressions, combining left and right operands with an binary operator+binaryOperation :: String -> Expr -> Expr -> Expr+binaryOperation symbol left right = Var symbol :$ [left, right] --- Match and throw away any white space around an expression.-exprN A0 =- do- _ <- genSpace- expr <- exprN A1- _ <- genSpace- return expr- *<|> exprN A1+-- | An assignment expression within a let's bindings list+assignment :: GenParser Char st Expr+assignment = do+ ident <- matchIdentifier+ expression <- matchTok '=' *> expr0+ pure $ ListE [Var ident, expression] +-- | build nested let statements when foldr'd.+bindLets :: Expr -> Expr -> Expr+bindLets (ListE [Var boundName, boundExpr]) nestedExpr = LamE [Name boundName] nestedExpr :$ [boundExpr]+bindLets _ e = e
+ Graphics/Implicit/ExtOpenScad/Parser/Lexer.hs view
@@ -0,0 +1,141 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Copyright (C) 2016, Kelvin Cookshaw (kelvin@cookshaw.com)+-- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)+-- Released under the GNU AGPLV3+, see LICENSE++-- allow us to specify what package to import what module from.+-- We don't actually care, but when we compile our haskell examples, we do.+{-# LANGUAGE PackageImports #-}++module Graphics.Implicit.ExtOpenScad.Parser.Lexer (whiteSpace, matchTrue, matchFalse, matchFunction, matchInclude, matchUse, matchIf, matchElse, matchModule, matchLet, matchUndef, matchTok, matchColon, matchSemi, matchComma, matchIdentifier, surroundedBy, matchLT, matchLE, matchGT, matchGE, matchEQ, matchNE, matchCAT, matchOR, matchAND, matchEach, lexer) where++import Prelude (String, Char, Bool(True), (>>), pure)++import "monads-tf" Control.Monad.Identity (Identity)++import Text.Parsec.String (GenParser)++import qualified Text.Parsec.Token as P (whiteSpace, reserved, identifier, reservedOp)++import Text.Parsec.Language (GenLanguageDef, emptyDef)++import Text.Parsec.Token (GenTokenParser, makeTokenParser, commentStart, commentEnd, commentLine, nestedComments, caseSensitive, colon, semi, comma, identStart, identLetter, reservedNames, reservedOpNames)++import Text.Parsec (char, between)++import Text.Parsec.Char (noneOf)++-- The definition of openscad used by parsec.+openScadStyle :: GenLanguageDef String u0 Identity+openScadStyle+ = emptyDef+ { commentStart = "/*"+ , commentEnd = "*/"+ , commentLine = "//"+ , nestedComments = True+ , identStart = noneOf " ,|[]{}()+-*&^%#@!~`'\"\\/;:.,<>?=1234567890"+ , identLetter = noneOf " ,|[]{}()+-*&^%#@!~`'\"\\/;:.,<>?="+ , reservedNames = ["module", "function", "if", "else", "let", "each", "true", "false", "undef", "include", "use"]+ , reservedOpNames= ["<=", ">=", "==", "!=", "&&", "||"]+ , caseSensitive = True+ }++lexer :: GenTokenParser String st Identity+lexer = makeTokenParser openScadStyle++-- | Consume whitespace.+whiteSpace :: GenParser Char st ()+whiteSpace = P.whiteSpace lexer++-- | Match boolean true.+matchTrue :: GenParser Char st ()+matchTrue = P.reserved lexer "true"++-- | Match boolean false+matchFalse :: GenParser Char st ()+matchFalse = P.reserved lexer "false"++-- | Match the function keyword.+matchFunction :: GenParser Char st ()+matchFunction = P.reserved lexer "function"++-- | Match the include keyword.+matchInclude :: GenParser Char st ()+matchInclude = P.reserved lexer "include"++-- | Match the use keyword.+matchUse :: GenParser Char st ()+matchUse = P.reserved lexer "use"++-- | Match the if keyword.+matchIf :: GenParser Char st ()+matchIf = P.reserved lexer "if"++-- | Match the else keyword.+matchElse :: GenParser Char st ()+matchElse = P.reserved lexer "else"++-- | Match the module keyword.+matchModule :: GenParser Char st ()+matchModule = P.reserved lexer "module"++-- | Match the let keyword.+matchLet :: GenParser Char st ()+matchLet = P.reserved lexer "let"++-- | Match the undef keyword.+matchUndef :: GenParser Char st ()+matchUndef = P.reserved lexer "undef"++-- | Match the each keyword.+matchEach :: GenParser Char st ()+matchEach = P.reserved lexer "each"++-- | match a single character token followed by whitespace.+matchTok :: Char -> GenParser Char st String+matchTok x = do+ y <- char x+ _ <- P.whiteSpace lexer+ pure [y]+--matchTok tok = lexeme lexer $ symbol lexer [tok]++-- | match a colon.+matchColon :: GenParser Char st String+matchColon = colon lexer++-- | match a semicolon.+matchSemi :: GenParser Char st String+matchSemi = semi lexer++-- | match a comma.+matchComma :: GenParser Char st String+matchComma = comma lexer++-- | Match operators.+matchLE :: GenParser Char st String+matchLE = P.reservedOp lexer "<=" >> pure "<="+matchLT :: GenParser Char st String+matchLT = matchTok '<'+matchGE :: GenParser Char st String+matchGE = P.reservedOp lexer ">=" >> pure ">="+matchGT :: GenParser Char st String+matchGT = matchTok '>'+matchEQ :: GenParser Char st String+matchEQ = P.reservedOp lexer "==" >> pure "=="+matchNE :: GenParser Char st String+matchNE = P.reservedOp lexer "!=" >> pure "!="+matchAND :: GenParser Char st String+matchAND = P.reservedOp lexer "&&" >> pure "&&"+matchOR :: GenParser Char st String+matchOR = P.reservedOp lexer "||" >> pure "||"+matchCAT :: GenParser Char st String+matchCAT = P.reservedOp lexer "++" >> pure "++"+++-- | match something between two ends.+surroundedBy :: Char -> GenParser Char st a -> Char -> GenParser Char st a+surroundedBy leftTok middle rightTok = between (matchTok leftTok) (matchTok rightTok) middle++-- | match an identifier. variable name, function name, module name, etc.+matchIdentifier :: GenParser Char st String+matchIdentifier = P.identifier lexer
Graphics/Implicit/ExtOpenScad/Parser/Statement.hs view
@@ -2,67 +2,73 @@ -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}---- FIXME: required. why?-{-# LANGUAGE KindSignatures #-}+-- Allow us to use a shorter form of Name.+{-# LANGUAGE PatternSynonyms #-} -- 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)+import Prelude(Char, Either, String, ($), (*>), Bool(False, True), (<$>), (<*>), (.), (<$), flip, fmap, filter, not, pure) -import Text.ParserCombinators.Parsec (try, sepBy, sourceLine, GenParser, oneOf, space, char, getPosition, parse, many1, eof, string, SourceName, ParseError, many, noneOf, Line, (<|>), (<?>))+import Data.Maybe(Maybe(Just, Nothing)) -import Text.Parsec.Prim (ParsecT)+import Graphics.Implicit.ExtOpenScad.Definitions (Statement(DoNothing, NewModule, Include, If, ModuleCall, (:=)), Expr(LamE), StatementI(StatementI), Symbol(Symbol), SourcePosition) -import Data.Functor.Identity(Identity)+import qualified Graphics.Implicit.ExtOpenScad.Definitions as GIED (Pattern(Name)) -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)+import Graphics.Implicit.ExtOpenScad.Parser.Util ((*<|>), patternMatcher, sourcePosition) -- the top level of the expression parser. import Graphics.Implicit.ExtOpenScad.Parser.Expr (expr0) -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+-- The lexer.+import Graphics.Implicit.ExtOpenScad.Parser.Lexer (whiteSpace, matchFunction, matchInclude, matchUse, matchIf, matchElse, matchModule, matchTok, matchComma, matchSemi, surroundedBy, matchIdentifier) +-- We use parsec to parse.+import Text.Parsec (SourceName, (<?>), sepBy, oneOf, getPosition, parse, eof, ParseError, many, noneOf, option, between, char, optionMaybe)++import Text.Parsec.String (GenParser)++import Control.Applicative ((<*), (<|>))++import Data.Functor (($>))++-- Let us use the old syntax when defining Names.+pattern Name :: String -> GIED.Pattern+pattern Name n = GIED.Name (Symbol n)++data CompIdx = A1 | A2++-- | all of the token parsers are lexemes which consume all trailing spaces nicely.+-- | This leaves us to deal only with the first spaces in the file.+parseProgram :: SourceName -> String -> Either ParseError [StatementI]+parseProgram = parse program where+ program :: GenParser Char st [StatementI]+ program = removeNoOps <$> (whiteSpace *> many (computation A1) <* eof)++ -- | A computable block of code in our openscad-like programming language.-computation :: GenParser Char st StatementI-computation =- do -- suite statements: no semicolon...- _ <- genSpace- s <- tryMany [- ifStatementI,- forStatementI,- throwAway,- userModuleDeclaration- ]- _ <- genSpace- return s- *<|> do -- Non suite statements. Semicolon needed...- _ <- genSpace- s <- tryMany [- echo,- include, -- also handles use- function,- assignment- ]- _ <- stringGS " ; "- return s- *<|> do -- Modules. no semicolon...- _ <- genSpace- s <- userModule- _ <- genSpace- return s+computation :: CompIdx -> GenParser Char st StatementI+computation A1 =+ computation A2+ <|>+ throwAway -{-+computation A2 =+ -- suite statements: no semicolon...+ userModule+ <|>+ ifStatementI+ <|>+ userModuleDeclaration+ <|> -- Non suite statements. Semicolon needed...+ ( include+ <|>+ function+ ) <* matchSemi+ *<|>+ assignment <* matchSemi+ -- | A suite of s! -- What's a suite? Consider: --@@ -77,182 +83,113 @@ -- -- We consider it to be a list of computables which -- are in turn StatementI s.--} suite :: GenParser Char st [StatementI]-suite = (fmap return computation <|> do- _ <- char '{'- _ <- genSpace- stmts <- many (try computation)- _ <- genSpace- _ <- char '}'- return stmts- ) <?> " suite"+suite = (+ removeNoOps . (:[]) <$> computation A1+ *<|>+ removeNoOps <$> surroundedBy '{' (many (computation A1)) '}'+ ) <?> "suite" --- commenting out a comuptation: use % or * before the statement, and it will not be run.+-- | Every StatementI requires a source position, thus we can build a combinator.+statementI :: GenParser Char st (Statement StatementI) -> GenParser Char st StatementI+statementI p = StatementI <$> sourcePos <*> p++-- | Commenting out a computation: use % or * before the statement, and it will not be run. throwAway :: GenParser Char st StatementI-throwAway = do- line <- lineNumber- _ <- genSpace- _ <- oneOf "%*"- _ <- genSpace- _ <- computation- return $ StatementI line DoNothing+throwAway = statementI $ DoNothing <$ oneOf "%*" <* whiteSpace <* computation A2 --- An include! Basically, inject another openscad file here...+-- | An include! Basically, inject another extopenscad file here... include :: GenParser Char st StatementI-include = (do- line <- lineNumber- injectVals <- (string "include" >> return True )- <|> (string "use" >> return False)- _ <- stringGS " < "- filename <- many (noneOf "<> ")- _ <- stringGS " > "- return $ StatementI line $ Include filename injectVals- ) <?> "include "+include = statementI p <?> "include/use"+ where+ p :: GenParser Char st (Statement StatementI)+ p = flip Include+ <$> (matchInclude $> True <|> matchUse $> False)+ -- FIXME: better definition of valid filename characters.+ <*> between (char '<') (matchTok '>') (many $ noneOf "<> ") -- | An assignment (parser) assignment :: GenParser Char st StatementI-assignment = ("assignment " ?:) $- do- line <- lineNumber- lvalue <- patternMatcher- _ <- stringGS " = "- valExpr <- expr0- return $ StatementI line $ lvalue := valExpr+assignment = statementI p <?> "assignment"+ where+ p :: GenParser Char st (Statement StatementI)+ p = (:=) <$> patternMatcher <* matchTok '=' <*> expr0 -- | A function declaration (parser) function :: GenParser Char st StatementI-function = ("function " ?:) $- do- line <- lineNumber- 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)-echo :: GenParser Char st StatementI-echo = do- line <- lineNumber- _ <- stringGS "echo ( "- exprs <- expr0 `sepBy` stringGS " , "- _ <- stringGS " ) "- return $ StatementI line $ Echo exprs+function = statementI p <?> "function"+ where+ p :: GenParser Char st (Statement StatementI)+ p = (:=) <$> lval <*> rval+ lval :: GenParser Char st GIED.Pattern+ lval = Name <$> (matchFunction *> matchIdentifier)+ rval :: GenParser Char st Expr+ rval = LamE <$> surroundedBy '(' (sepBy patternMatcher matchComma) ')' <*> (matchTok '=' *> expr0) +-- | An if statement (parser) ifStatementI :: GenParser Char st StatementI-ifStatementI =- "if " ?: do- line <- lineNumber- _ <- stringGS "if ( "- bexpr <- expr0- _ <- stringGS " ) "- sTrueCase <- suite- _ <- genSpace- sFalseCase <- (stringGS "else " >> suite ) *<|> return []- return $ StatementI line $ If bexpr sTrueCase sFalseCase--forStatementI :: GenParser Char st StatementI-forStatementI =- "for " ?: do- line <- lineNumber- -- a for loop is of the form:- -- for ( vsymb = vexpr ) loops- -- eg. for ( a = [1,2,3] ) {echo(a); echo "lol";}- -- eg. for ( [a,b] = [[1,2]] ) {echo(a+b); echo "lol";}- _ <- stringGS "for ( "- lvalue <- patternMatcher- _ <- stringGS " = "- vexpr <- expr0- _ <- stringGS " ) "- loopContent <- suite- return $ StatementI line $ For lvalue vexpr loopContent+ifStatementI = statementI p <?> "if"+ where+ p :: GenParser Char st (Statement StatementI)+ p = If <$> (matchIf *> surroundedBy '(' expr0 ')') <*> suite <*> option [] (matchElse *> suite) --- parse a call to a module.+-- | parse a call to a module. userModule :: GenParser Char st StatementI-userModule = do- line <- lineNumber- name <- variableSymb- _ <- genSpace- args <- moduleArgsUnit- _ <- genSpace- s <- suite *<|> (stringGS " ; " >> return [])- return $ StatementI line $ ModuleCall name args s+userModule = statementI p <?> "module call"+ where+ p :: GenParser Char st (Statement StatementI)+ p = ModuleCall <$> fmap Symbol matchIdentifier <*> moduleArgsUnit <*> (suite *<|> (matchSemi $> [])) --- declare a module.+-- | declare a module. userModuleDeclaration :: GenParser Char st StatementI-userModuleDeclaration = do- line <- lineNumber- _ <- stringGS "module "- newModuleName <- variableSymb- _ <- genSpace- args <- moduleArgsUnitDecl- _ <- genSpace- s <- suite- return $ StatementI line $ NewModule newModuleName args s+userModuleDeclaration = statementI p <?> "module declaration"+ where+ p :: GenParser Char st (Statement StatementI)+ p = NewModule <$> fmap Symbol (matchModule *> matchIdentifier) <*> moduleArgsUnitDecl <*> suite --- parse the arguments passed to a module.-moduleArgsUnit :: GenParser Char st [(Maybe String, Expr)]-moduleArgsUnit = do- _ <- stringGS " ( "- args <- sepBy (+-- | parse the arguments passed to a module.+moduleArgsUnit :: GenParser Char st [(Maybe Symbol, Expr)]+moduleArgsUnit =+ surroundedBy '('+ (sepBy ( do -- eg. a = 12- symb <- variableSymb- _ <- stringGS " = "- expr <- expr0- return (Just symb, expr)+ symb <- matchIdentifier+ expr <- matchTok '=' *> expr0+ pure (Just (Symbol symb), expr) *<|> do -- eg. a(x,y) = 12- symb <- variableSymb- _ <- stringGS " ( "- argVars <- sepBy variableSymb (try $ stringGS " , ")- _ <- stringGS " ) = "- expr <- expr0- return (Just symb, LamE (map Name argVars) expr)+ symb <- matchIdentifier+ argVars <- surroundedBy '(' (sepBy matchIdentifier matchComma) ')'+ expr <- matchTok '=' *> expr0+ pure (Just (Symbol symb), LamE (fmap Name argVars) expr) *<|> do -- eg. 12 expr <- expr0- return (Nothing, expr)- ) (try $ stringGS " , ")- _ <- stringGS " ) "- return args+ pure (Nothing, expr)+ ) matchComma)+ ')' --- parse the arguments in the module declaration.-moduleArgsUnitDecl :: GenParser Char st [(String, Maybe Expr)]-moduleArgsUnitDecl = do- _ <- stringGS " ( "- argTemplate <- sepBy (+-- | parse the arguments in the module declaration.+moduleArgsUnitDecl :: GenParser Char st [(Symbol, Maybe Expr)]+moduleArgsUnitDecl =+ surroundedBy '('+ (sepBy ( do- symb <- variableSymb;- _ <- stringGS " = "- expr <- expr0- return (symb, Just expr)- *<|> do- symb <- variableSymb;- _ <- stringGS " ( "- -- FIXME: why match this content, then drop it?- _ <- sepBy variableSymb (try $ stringGS " , ")- _ <- stringGS " ) = "- expr <- expr0- return (symb, Just expr)- *<|> do- symb <- variableSymb- return (symb, Nothing)- ) (try $ stringGS " , ")- _ <- stringGS " ) "- return argTemplate+ symb <- matchIdentifier+ expr <- optionMaybe (matchTok '=' *> expr0)+ pure (Symbol symb, expr)+ ) matchComma)+ ')' --- find the line number. used when generating errors.-lineNumber :: forall s u (m :: * -> *).- Monad m => ParsecT s u m Line-lineNumber = fmap sourceLine getPosition+-- | Find the source position. Used when generating errors.+sourcePos :: GenParser Char st SourcePosition+sourcePos = sourcePosition <$> 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--}+isNoOp :: StatementI -> Bool+isNoOp (StatementI _ DoNothing) = True+isNoOp _ = False++-- | Remove statements that do nothing.+removeNoOps :: [StatementI] -> [StatementI]+removeNoOps = filter $ not . isNoOp
Graphics/Implicit/ExtOpenScad/Parser/Util.hs view
@@ -2,98 +2,105 @@ -- Copyright (C) 2016 Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}+module Graphics.Implicit.ExtOpenScad.Parser.Util ((*<|>), (?:), tryMany, patternMatcher, sourcePosition, number, variable, boolean, scadString, scadUndefined) where --- FIXME: required. why?-{-# LANGUAGE KindSignatures, FlexibleContexts #-}+import Prelude (String, Char, ($), foldl1, fmap, (.), pure, (*>), Bool(True, False), read, (**), (*), (==), (<>), (<$>), (<$)) -module Graphics.Implicit.ExtOpenScad.Parser.Util (genSpace, pad, (*<|>), (?:), stringGS, padString, tryMany, variableSymb, patternMatcher) where+import Text.Parsec (SourcePos, (<|>), (<?>), try, char, sepBy, noneOf, string, many, digit, many1, optional, choice, option, oneOf, between) -import Prelude (String, Char, ($), (++), foldl1, map, (>>), (.), return)+import Text.Parsec.String (GenParser) -import Text.ParserCombinators.Parsec (GenParser, many, oneOf, noneOf, (<|>), try, string, manyTill, anyChar, (<?>), char, many1, sepBy)+import qualified Text.Parsec as P (sourceLine, sourceColumn, sourceName) -import Text.Parsec.Prim (ParsecT, Stream)+import Text.Parsec.Prim (ParsecT) import Data.Functor.Identity (Identity) -import Graphics.Implicit.ExtOpenScad.Definitions (Pattern(Wild, Name, ListP))+import Graphics.Implicit.ExtOpenScad.Definitions (Pattern(Wild, Name, ListP), SourcePosition(SourcePosition), Symbol(Symbol), Expr(LitE, Var), OVal(ONum, OString, OBool, OUndefined)) --- white space, including tabs, newlines and comments-genSpace :: ParsecT String u Identity String-genSpace = many $- oneOf " \t\n\r"- <|> try ( do- _ <- string "//"- _ <- many ( noneOf "\n")- return ' '- ) <|> try ( do- _ <- string "/*"- _ <- manyTill anyChar (try $ string "*/")- return ' '- )+import Graphics.Implicit.Definitions (toFastℕ) --- a padded ... parser?-pad :: ParsecT String u Identity b -> ParsecT String u Identity b-pad parser = do- _ <- genSpace- a <- parser- _ <- genSpace- return a+-- The lexer.+import Graphics.Implicit.ExtOpenScad.Parser.Lexer (matchIdentifier, matchTok, matchUndef, matchTrue, matchFalse, whiteSpace, surroundedBy, matchComma) +import Data.Functor (($>))+ infixr 1 *<|>-(*<|>) :: forall u a tok. GenParser tok u a -> ParsecT [tok] u Identity a -> ParsecT [tok] u Identity a+(*<|>) :: GenParser tok u a -> ParsecT [tok] u Identity a -> ParsecT [tok] u Identity a a *<|> b = try a <|> b infixr 2 ?:-(?:) :: forall s u (m :: * -> *) a. String -> ParsecT s u m a -> ParsecT s u m a+(?:) :: String -> ParsecT s u m a -> ParsecT s u m a l ?: p = p <?> l -stringGS :: String -> ParsecT String u Identity String-stringGS (' ':xs) = do- x' <- genSpace- xs' <- stringGS xs- return (x' ++ xs')-stringGS (x:xs) = do- x' <- char x- xs' <- stringGS xs- return (x' : xs')-stringGS "" = return ""+tryMany :: [GenParser tok u a] -> ParsecT [tok] u Identity a+tryMany = foldl1 (<|>) . fmap try --- a padded string-padString :: String -> ParsecT String u Identity String-padString s = do- _ <- genSpace- s' <- string s- _ <- genSpace- return s'+-- | A pattern parser+patternMatcher :: GenParser Char st Pattern+patternMatcher = "pattern" ?:+ (Wild <$ char '_')+ <|> ( Name . Symbol <$> matchIdentifier)+ <|> ( ListP <$> surroundedBy '[' (patternMatcher `sepBy` matchComma) ']' ) -tryMany :: forall u a tok. [GenParser tok u a] -> ParsecT [tok] u Identity a-tryMany = foldl1 (<|>) . map try+-- expression parsers -variableSymb :: forall s u (m :: * -> *). Stream s m Char => ParsecT s u m String-variableSymb = many1 (noneOf " ,|[]{}()+-*&^%#@!~`'\"\\/;:.,<>?=") <?> "variable"+-- | Parse a number.+number :: GenParser Char st Expr+number = ("number" ?:) $ do+ h <- choice+ [+ do+ a <- many1 digit+ b <- option "" ( ('.':) <$> (char '.' *> many1 digit) )+ pure (a <> b)+ ,+ ("0." <>) <$> (char '.' *> many1 digit)+ ]+ d <- option "0"+ (+ oneOf "eE" *> choice+ [+ ('-':) <$> (char '-' *> many1 digit)+ ,+ optional (char '+') *> many1 digit+ ]+ )+ _ <- whiteSpace+ pure . LitE $ ONum $ if d == "0"+ then read h+ else read h * (10 ** read d) -patternMatcher :: GenParser Char st Pattern-patternMatcher =- (do- _ <- char '_'- return Wild- ) <|> {-( do- a <- literal- return $ \obj ->- if obj == (a undefined)- then Just (Map.empty)- else Nothing- ) <|> -} ( do- symb <- variableSymb- return $ Name symb- ) <|> ( do- _ <- char '['- _ <- genSpace- components <- patternMatcher `sepBy` try (genSpace >> char ',' >> genSpace)- _ <- genSpace- _ <- char ']'- return $ ListP components- )+-- | Parse a variable reference.+-- NOTE: abused by the parser for function calls.+variable :: GenParser Char st Expr+variable = "variable" ?:+ Var . Symbol <$> matchIdentifier++-- | Parse a true or false value.+boolean :: GenParser Char st Expr+boolean = "boolean" ?:+ LitE . OBool <$> (matchTrue $> True <|> matchFalse $> False)++-- | Parse a quoted string.+-- FIXME: no \u unicode support?+scadString :: GenParser Char st Expr+scadString = "string" ?: LitE . OString <$>+ between+ (char '"')+ (matchTok '"')+ (many $+ (string "\\\"" $> '\"') *<|>+ (string "\\n" $> '\n') *<|>+ (string "\\r" $> '\r') *<|>+ (string "\\t" $> '\t') *<|>+ (string "\\\\" $> '\\') *<|>+ noneOf "\"\n"+ )++scadUndefined :: GenParser Char st Expr+scadUndefined = "undefined" ?:+ LitE OUndefined <$ matchUndef++sourcePosition :: SourcePos -> SourcePosition+sourcePosition pos = SourcePosition (toFastℕ $ P.sourceLine pos) (toFastℕ $ P.sourceColumn pos) (P.sourceName pos)
Graphics/Implicit/ExtOpenScad/Primitives.hs view
@@ -2,64 +2,114 @@ -- Copyright 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Idealy, we'd like to parse openscad code, with some improvements, for backwards compatability.+-- Idealy, we'd like to parse a superset of openscad code, with some improvements. -- This file provides primitive objects for the openscad parser. --- FIXME: why are these required?-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+-- Allow us to use type signatures in patterns.+{-# LANGUAGE ScopedTypeVariables #-} --- Export one set containing all of the primitive object's patern matches.-module Graphics.Implicit.ExtOpenScad.Primitives (primitives) where+-- Export one set containing all of the primitive modules.+module Graphics.Implicit.ExtOpenScad.Primitives (primitiveModules) where -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 Prelude(String, Either(Left, Right), Bool(True, False), Maybe(Just, Nothing), ($), pure, either, id, (-), (==), (&&), (<), (*), cos, sin, pi, (/), (>), const, uncurry, fromInteger, round, (/=), (||), not, null, fmap, (<>), otherwise) -import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, ℕ, SymbolicObj2, SymbolicObj3)+import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, ℕ, SymbolicObj2, SymbolicObj3, fromℕtoℝ) -import Graphics.Implicit.ExtOpenScad.Definitions (OVal (OObj2, OObj3), ArgParser)+import Graphics.Implicit.ExtOpenScad.Definitions (OVal (OObj2, OObj3, ONModule), ArgParser, Symbol(Symbol), StateC, SourcePosition) -import Graphics.Implicit.ExtOpenScad.Util.ArgParser (doc, defaultTo, argument, example, test, eulerCharacteristic)+import Graphics.Implicit.ExtOpenScad.Util.ArgParser (doc, defaultTo, example, test, eulerCharacteristic) -import Graphics.Implicit.ExtOpenScad.Util.OVal (caseOType, divideObjs, (<||>))+import qualified Graphics.Implicit.ExtOpenScad.Util.ArgParser as GIEUA (argument) +import Graphics.Implicit.ExtOpenScad.Util.OVal (OTypeMirror, caseOType, divideObjs, (<||>))++import Graphics.Implicit.ExtOpenScad.Util.StateC (errorC)++-- Note the use of a qualified import, so we don't have the functions in this file conflict with what we're importing. import qualified Graphics.Implicit.Primitives as Prim (sphere, rect3R, rectR, translate, circle, polygonR, extrudeR, cylinder2, union, unionR, intersect, intersectR, difference, differenceR, rotate, rotate3V, rotate3, scale, extrudeR, extrudeRM, rotateExtrude, shell, pack3, pack2) -import Data.Maybe (isNothing)+import Control.Monad (mplus) -import qualified Control.Monad as Monad+import Data.AffineSpace (distanceSq) -import Data.VectorSpace (VectorSpace, Scalar, (*^))-import GHC.Real (RealFrac)+default (ℝ) -primitives :: [(String, [OVal] -> ArgParser (IO [OVal]) )]-primitives = [ sphere, cube, square, cylinder, circle, polygon, union, difference, intersect, translate, scale, rotate, extrude, pack, shell, rotateExtrude, unit ]+-- | Use the old syntax when defining arguments.+argument :: OTypeMirror desiredType => String -> ArgParser desiredType+argument a = GIEUA.argument (Symbol a) --- sphere is a module without a suite.--- this means that the parser will look for this like--- sphere(args...);-sphere :: (String, [OVal] -> ArgParser (IO [OVal]))-sphere = moduleWithoutSuite "sphere" $ do+-- | The only thing exported here. basically, a list of modules.+primitiveModules :: [(Symbol, OVal)]+primitiveModules =+ [+ onModIze sphere [([("r", noDefault)], noSuite), ([("d", noDefault)], noSuite)]+ , onModIze cube [([("x", noDefault), ("y", noDefault), ("z", noDefault), ("center", hasDefault), ("r", hasDefault)], noSuite),([("size", noDefault), ("center", hasDefault), ("r", hasDefault)], noSuite)]+ , onModIze square [([("x", noDefault), ("y", noDefault), ("center", hasDefault), ("r", hasDefault)], noSuite), ([("size", noDefault), ("center", hasDefault), ("r", hasDefault)], noSuite)]+ , onModIze cylinder [([("r", hasDefault), ("h", hasDefault), ("r1", hasDefault), ("r2", hasDefault), ("$fn", hasDefault), ("center", hasDefault)], noSuite),+ ([("d", hasDefault), ("h", hasDefault), ("d1", hasDefault), ("d2", hasDefault), ("$fn", hasDefault), ("center", hasDefault)], noSuite)]+ , onModIze circle [([("r", noDefault), ("$fn", hasDefault)], noSuite), ([("d", noDefault), ("$fn", hasDefault)], noSuite)]+ , onModIze polygon [([("points", noDefault)], noSuite)]+ , onModIze union [([("r", hasDefault)], requiredSuite)]+ , onModIze intersect [([("r", hasDefault)], requiredSuite)]+ , onModIze difference [([("r", hasDefault)], requiredSuite)]+ , onModIze translate [([("x", noDefault), ("y", noDefault), ("z", noDefault)], requiredSuite), ([("v", noDefault)], requiredSuite)]+ , onModIze rotate [([("a", noDefault), ("v", hasDefault)], requiredSuite)]+ , onModIze scale [([("v", noDefault)], requiredSuite)]+ , onModIze extrude [([("height", hasDefault), ("center", hasDefault), ("twist", hasDefault), ("scale", hasDefault), ("translate", hasDefault), ("r", hasDefault)], requiredSuite)]+ , onModIze rotateExtrude [([("a", hasDefault), ("r", hasDefault), ("translate", hasDefault), ("rotate", hasDefault)], requiredSuite)]+ , onModIze shell [([("w", noDefault)], requiredSuite)]+ , onModIze pack [([("size", noDefault), ("sep", noDefault)], requiredSuite)]+ , onModIze unit [([("unit", noDefault)], requiredSuite)]+ ]+ where+ hasDefault = True+ noDefault = False+ noSuite :: Maybe Bool+ noSuite = Nothing+ requiredSuite = Just True+ onModIze func rawInstances = (name, ONModule name implementation instances)+ where+ (name, implementation) = func+ instances = fmap fixup rawInstances+ fixup :: ([(String, Bool)], Maybe Bool) -> ([(Symbol, Bool)], Maybe Bool)+ fixup (args, suiteInfo) = (fmap fixupArgs args, suiteInfo)+ where+ fixupArgs :: (String, Bool) -> (Symbol, Bool)+ fixupArgs (symbol, maybeDefault) = (Symbol symbol, maybeDefault)++-- | sphere is a module without a suite.+-- this means that the parser will look for this like+-- sphere(args...);+sphere :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+sphere = moduleWithoutSuite "sphere" $ \_ _ -> do example "sphere(3);" example "sphere(r=5);" -- 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"+ r <-+ do+ radius :: ℝ <- argument "r" `doc` "radius of the sphere"+ pure radius+ <|> do+ diameter :: ℝ <- argument "d" `doc` "diameter of the sphere"+ pure $ diameter/2+ -- This module adds a 3D object, a sphere of radius r, -- using the sphere implementation in Prim -- (Graphics.Implicit.Primitives) addObj3 $ Prim.sphere r -cube :: (String, [OVal] -> ArgParser (IO [OVal]))-cube = moduleWithoutSuite "cube" $ do-+-- | FIXME: square1, square2 like cylinder has?+-- | FIXME: translate for square2?+cube :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+cube = moduleWithoutSuite "cube" $ \_ _ -> do -- examples example "cube(size = [2,3,4], center = true, r = 0.5);" example "cube(4);"-- -- arguments+ -- arguments (two forms) ((x1,x2), (y1,y2), (z1,z2)) <- do x :: Either ℝ ℝ2 <- argument "x"@@ -72,9 +122,9 @@ `doc` "should center? (non-intervals)" `defaultTo` False let- toInterval' :: Fractional t => t -> (t, t)+ toInterval' :: ℝ -> ℝ2 toInterval' = toInterval center- return (either toInterval' id x,+ pure (either toInterval' id x, either toInterval' id y, either toInterval' id z) <|> do@@ -84,29 +134,28 @@ `doc` "should center?" `defaultTo` False let (x,y, z) = either (\w -> (w,w,w)) id size- return (toInterval center x, toInterval center y, toInterval center z)-+ pure (toInterval center x, toInterval center y, toInterval center z)+ -- arguments shared between forms r :: ℝ <- argument "r" `doc` "radius of rounding" `defaultTo` 0- -- Tests test "cube(4);" `eulerCharacteristic` 2 test "cube(size=[2,3,4]);" `eulerCharacteristic` 2-+ test "cube([2,3,4]);" -- openscad syntax+ `eulerCharacteristic` 2+ -- Implementation addObj3 $ Prim.rect3R r (x1, y1, z1) (x2, y2, z2) -square :: (String, [OVal] -> ArgParser (IO [OVal]))-square = moduleWithoutSuite "square" $ do-+square :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+square = moduleWithoutSuite "square" $ \_ _ -> do -- examples example "square(x=[-2,2], y=[-1,5]);" example "square(size = [3,4], center = true, r = 0.5);" example "square(4);"-- -- arguments+ -- arguments (two forms) ((x1,x2), (y1,y2)) <- do x :: Either ℝ ℝ2 <- argument "x"@@ -117,9 +166,9 @@ `doc` "should center? (non-intervals)" `defaultTo` False let- toInterval' :: Fractional t => t -> (t, t)+ toInterval' :: ℝ -> ℝ2 toInterval' = toInterval center- return (either toInterval' id x,+ pure (either toInterval' id x, either toInterval' id y) <|> do size :: Either ℝ ℝ2 <- argument "size"@@ -128,53 +177,64 @@ `doc` "should center?" `defaultTo` False let (x,y) = either (\w -> (w,w)) id size- return (toInterval center x, toInterval center y)-+ pure (toInterval center x, toInterval center y)+ -- arguments shared between forms r :: ℝ <- argument "r" `doc` "radius of rounding" `defaultTo` 0- -- Tests test "square(2);" `eulerCharacteristic` 0 test "square(size=[2,3]);" `eulerCharacteristic` 0-+ -- Implementation addObj2 $ Prim.rectR r (x1, y1) (x2, y2) -cylinder :: (String, [OVal] -> ArgParser (IO [OVal]))-cylinder = moduleWithoutSuite "cylinder" $ do-+cylinder :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+cylinder = moduleWithoutSuite "cylinder" $ \_ _ -> do example "cylinder(r=10, h=30, center=true);" example "cylinder(r1=4, r2=6, h=10);" example "cylinder(r=5, h=10, $fn = 6);"- -- arguments- r :: ℝ <- argument "r"- `defaultTo` 1- `doc` "radius of cylinder"+ (r,r1,r2) <-+ do+ radius :: ℝ <- argument "r"+ `defaultTo` 1+ `doc` "radius of cylinder"+ radius1 :: ℝ <- argument "r1"+ `defaultTo` 1+ `doc` "bottom radius; overrides r"+ radius2 :: ℝ <- argument "r2"+ `defaultTo` 1+ `doc` "top radius; overrides r"+ pure (radius, radius1, radius2)+ <|> do+ diameter :: ℝ <- argument "d"+ `defaultTo` 2+ `doc` "diameter of cylinder"+ diameter1 :: ℝ <- argument "d1"+ `defaultTo` 2+ `doc` "bottom diameter; overrides d"+ diameter2 :: ℝ <- argument "d2"+ `defaultTo` 2+ `doc` "top diameter; overrides d"+ pure (diameter/2, diameter1/2, diameter2/2)++ h :: Either ℝ ℝ2 <- argument "h" `defaultTo` Left 1 `doc` "height of cylinder"- r1 :: ℝ <- argument "r1"- `defaultTo` 1- `doc` "bottom radius; overrides r"- r2 :: ℝ <- argument "r2"- `defaultTo` 1- `doc` "top radius; overrides r"- fn :: ℕ <- argument "$fn"+ sides :: ℕ <- argument "$fn" `defaultTo` (-1) `doc` "number of sides, for making prisms" center :: Bool <- argument "center" `defaultTo` False `doc` "center cylinder with respect to z?"- -- Tests test "cylinder(r=10, h=30, center=true);" `eulerCharacteristic` 0 test "cylinder(r=5, h=10, $fn = 6);" `eulerCharacteristic` 0- let (h1, h2) = either (toInterval center) id h dh = h2 - h1@@ -183,95 +243,115 @@ if h1 == 0 then id else Prim.translate (0,0,h1)- -- The result is a computation state modifier that adds a 3D object, -- based on the args. addObj3 $ if r1 == 1 && r2 == 1 then let- obj2 = if fn < 0 then Prim.circle r else Prim.polygonR 0 $- let- sides :: ℝ- sides = fromIntegral fn- in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]]+ obj2 = if sides < 0 then Prim.circle r else Prim.polygonR 0+ [(r*cos θ, r*sin θ) | θ <- [2*pi*fromℕtoℝ n/fromℕtoℝ sides | n <- [0 .. sides - 1]]] obj3 = Prim.extrudeR 0 obj2 dh in shift obj3 else shift $ Prim.cylinder2 r1 r2 dh -circle :: (String, [OVal] -> ArgParser (IO [OVal]))-circle = moduleWithoutSuite "circle" $ do- +circle :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+circle = moduleWithoutSuite "circle" $ \_ _ -> do example "circle(r=10); // circle" example "circle(r=5, $fn=6); //hexagon"- -- Arguments- r :: ℝ <- argument "r"- `doc` "radius of the circle"- fn :: ℕ <- argument "$fn"- `doc` "if defined, makes a regular polygon with n sides instead of a circle"- `defaultTo` (-1)-+ r <-+ do+ radius :: ℝ <- argument "r"+ `doc` "radius of the circle"+ pure radius+ <|> do+ diameter :: ℝ <- argument "d"+ `doc` "diameter of the circle"+ pure $ diameter/2+ sides :: ℕ <- argument "$fn"+ `doc` "if defined, makes a regular polygon with n sides instead of a circle"+ `defaultTo` (-1) test "circle(r=10);" `eulerCharacteristic` 0-- addObj2 $ if fn < 3+ test "circle(d=20);"+ `eulerCharacteristic` 0+ addObj2 $ if sides < 3 then Prim.circle r- else Prim.polygonR 0 $- let- sides :: ℝ- sides = fromIntegral fn- in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]]+ else Prim.polygonR 0+ [(r*cos θ, r*sin θ) | θ <- [2*pi*fromℕtoℝ n/fromℕtoℝ sides | n <- [0 .. sides - 1]]] -polygon :: (String, [OVal] -> ArgParser (IO [OVal]))-polygon = moduleWithoutSuite "polygon" $ do- +-- | FIXME: 3D Polygons?+-- | FIXME: handle rectangles that are not grid alligned.+-- | FIXME: allow for rounding of polygon corners, specification of vertex ordering.+-- | FIXME: polygons have to have more than two points, or do not generate geometry, and generate an error.+polygon :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+polygon = moduleWithoutSuite "polygon" $ \_ _ -> do example "polygon ([(0,0), (0,10), (10,0)]);"- points :: [ℝ2] <- argument "points" `doc` "vertices of the polygon"+{- r :: ℝ <- argument "r"+ `doc` "rounding of the polygon corners" paths :: [ℕ] <- argument "paths"- `doc` "order to go through vertices; ignored for now"+ `doc` "order to go through vertices" `defaultTo` []- r :: ℝ <- argument "r"- `doc` "rounding of the polygon corners; ignored for now"- `defaultTo` 0 case paths of [] -> addObj2 $ Prim.polygonR r points- _ -> return $ return []-+ _ -> pure $ pure []+ `defaultTo` 0+-}+ let+ addPolyOrSquare pts+ | [p1,p2,p3,p4] <- pts =+ let+ d1d2 = distanceSq p1 p2+ d3d4 = distanceSq p3 p4+ d1d3 = distanceSq p1 p3+ d2d4 = distanceSq p2 p4+ d1d4 = distanceSq p1 p4+ d2d3 = distanceSq p2 p3+ isGridAligned :: ℝ2 -> ℝ2 -> Bool+ isGridAligned (x1, y1) (x2, y2) = x1 == x2 || y1 == y2+ -- | Rectangles have no overlapping points,+ -- the distance on each side is equal to it's opposing side,+ -- and the distance between the pairs of opposing corners are equal.+ in if (p1 /= p2 && p2 /= p3 && p3 /= p4 && p4 /= p1)+ && (d1d2==d3d4 && d1d3==d2d4)+ && (d1d4==d2d3) && isGridAligned p1 p2+ then Prim.rectR 0 p1 p3+ else Prim.polygonR 0 pts+ | otherwise = Prim.polygonR 0 points+ addObj2 $ addPolyOrSquare points -union :: (String, [OVal] -> ArgParser (IO [OVal]))-union = moduleWithSuite "union" $ \children -> do+union :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+union = moduleWithSuite "union" $ \_ children -> do r :: ℝ <- argument "r"- `defaultTo` 0.0+ `defaultTo` 0 `doc` "Radius of rounding for the union interface"- return $ return $ if r > 0+ pure $ pure $ if r > 0 then objReduce (Prim.unionR r) (Prim.unionR r) children else objReduce Prim.union Prim.union children -intersect :: (String, [OVal] -> ArgParser (IO [OVal]))-intersect = moduleWithSuite "intersection" $ \children -> do+intersect :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+intersect = moduleWithSuite "intersection" $ \_ children -> do r :: ℝ <- argument "r"- `defaultTo` 0.0+ `defaultTo` 0 `doc` "Radius of rounding for the intersection interface"- return $ return $ if r > 0+ pure $ pure $ if r > 0 then objReduce (Prim.intersectR r) (Prim.intersectR r) children else objReduce Prim.intersect Prim.intersect children -difference :: (String, [OVal] -> ArgParser (IO [OVal]))-difference = moduleWithSuite "difference" $ \children -> do+difference :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+difference = moduleWithSuite "difference" $ \_ children -> do r :: ℝ <- argument "r"- `defaultTo` 0.0+ `defaultTo` 0 `doc` "Radius of rounding for the difference interface"- return $ return $ if r > 0+ pure $ pure $ if r > 0 then objReduce (Prim.differenceR r) (Prim.differenceR r) children else objReduce Prim.difference Prim.difference children -translate :: (String, [OVal] -> ArgParser (IO [OVal]))-translate = moduleWithSuite "translate" $ \children -> do-+translate :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+translate = moduleWithSuite "translate" $ \_ children -> do example "translate ([2,3]) circle (4);" example "translate ([5,6,7]) sphere(5);"- (x,y,z) <- do x :: ℝ <- argument "x"@@ -281,35 +361,32 @@ z :: ℝ <- argument "z" `doc` "z amount to translate" `defaultTo` 0;- return (x,y,z);+ pure (x,y,z); <|> do v :: Either ℝ (Either ℝ2 ℝ3) <- argument "v" `doc` "vector to translate by"- return $ case v of+ pure $ case v of Left x -> (x,0,0) Right (Left (x,y) ) -> (x,y,0) Right (Right (x,y,z)) -> (x,y,z)- - return $ return $+ pure $ pure $ objMap (Prim.translate (x,y)) (Prim.translate (x,y,z)) children -deg2rad :: ℝ -> ℝ-deg2rad x = x / 180.0 * pi---- This is mostly insane-rotate :: (String, [OVal] -> ArgParser (IO [OVal]))-rotate = moduleWithSuite "rotate" $ \children -> do+-- | FIXME: rotating a module that is not found pures no geometry, instead of an error.+-- | FIXME: error reporting on fallthrough.+-- + FIXME: rotate(y=90) would be nice.+rotate :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [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) `doc` "Vector to rotate around if a is a single angle"- -- caseOType matches depending on whether size can be coerced into -- the right object. See Graphics.Implicit.ExtOpenScad.Util -- Entries must be joined with the operator <||> -- Final entry must be fall through.- return $ return $ caseOType a $+ pure $ pure $ caseOType a $ ( \θ -> objMap (Prim.rotate $ deg2rad θ) (Prim.rotate3V (deg2rad θ) v) children ) <||> ( \(yz,zx,xy) ->@@ -317,149 +394,126 @@ ) <||> ( \(yz,zx) -> objMap id (Prim.rotate3 (deg2rad yz, deg2rad zx, 0)) children ) <||> const []--scale :: (String, [OVal] -> ArgParser (IO [OVal]))-scale = moduleWithSuite "scale" $ \children -> do+ where+ deg2rad :: ℝ -> ℝ+ deg2rad x = x / 180 * pi +scale :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [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 <- argument "v" `doc` "vector or scalar to scale by"- let scaleObjs stretch2 stretch3 = objMap (Prim.scale stretch2) (Prim.scale stretch3) children- - return $ return $ case v of+ pure $ pure $ case v of Left x -> scaleObjs (x,1) (x,1,1) Right (Left (x,y)) -> scaleObjs (x,y) (x,y,1) Right (Right (x,y,z)) -> scaleObjs (x,y) (x,y,z) -extrude :: (String, [OVal] -> ArgParser (IO [OVal]))-extrude = moduleWithSuite "linear_extrude" $ \children -> do+-- | FIXME: avoid the approximation in getBox3. better definition of function()?+extrude :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+extrude = moduleWithSuite "linear_extrude" $ \_ children -> do example "linear_extrude(10) square(5);"- height :: Either ℝ (ℝ -> ℝ -> ℝ) <- argument "height" `defaultTo` Left 1 `doc` "height to extrude to..." center :: Bool <- argument "center" `defaultTo` False `doc` "center? (the z component)"- twist :: Maybe (Either ℝ (ℝ -> ℝ)) <- argument "twist" `defaultTo` Nothing+ twistArg :: Either ℝ (ℝ -> ℝ) <- argument "twist" `defaultTo` Left 0 `doc` "twist as we extrude, either a total amount to twist or a function..."- scaleArg :: Maybe (Either ℝ (ℝ -> ℝ)) <- argument "scale" `defaultTo` Nothing+ scaleArg :: Either ℝ (ℝ -> ℝ) <- argument "scale" `defaultTo` Left 1 `doc` "scale according to this funciton as we extrude..."- translateArg :: Maybe (Either ℝ2 (ℝ -> ℝ2)) <- argument "translate" `defaultTo` Nothing+ translateArg :: Either ℝ2 (ℝ -> ℝ2) <- argument "translate" `defaultTo` Left (0,0) `doc` "translate according to this funciton as we extrude..." r :: ℝ <- argument "r" `defaultTo` 0- `doc` "round the top?"- + `doc` "round the top/bottom." let heightn = case height of Left h -> h Right f -> f 0 0 height' = case height of+ Left a -> Left a Right f -> Right $ uncurry f- Left a -> Left a- shiftAsNeeded :: SymbolicObj3 -> SymbolicObj3 shiftAsNeeded = if center then Prim.translate (0,0,-heightn/2.0) else id-- funcify :: (VectorSpace a, Fractional (Scalar a)) => Either a (ℝ -> a) -> ℝ -> a- funcify (Left val) h = realToFrac (h/heightn) *^ val- funcify (Right f ) h = f h- - twist' = fmap funcify twist- scale' = fmap funcify scaleArg- translate' = fmap funcify translateArg- - return $ return $ obj2UpMap (+ isTwistID = case twistArg of+ Left constant -> constant == 0+ Right _ -> False+ isScaleID = case scaleArg of+ Left constant -> constant == 1+ Right _ -> False+ isTransID = case translateArg of+ Left constant -> constant == (0,0)+ Right _ -> False+ pure $ pure $ obj2UpMap ( \obj -> case height of- Left constHeight | isNothing twist && isNothing scaleArg && isNothing translateArg ->+ Left constHeight | isTwistID && isScaleID && isTransID -> shiftAsNeeded $ Prim.extrudeR r obj constHeight _ ->- shiftAsNeeded $ Prim.extrudeRM r twist' scale' translate' obj height'+ shiftAsNeeded $ Prim.extrudeRM r twistArg scaleArg translateArg obj height' ) children -rotateExtrude :: (String, [OVal] -> ArgParser (IO [OVal]))-rotateExtrude = moduleWithSuite "rotate_extrude" $ \children -> do+rotateExtrude :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+rotateExtrude = moduleWithSuite "rotate_extrude" $ \_ children -> do example "rotate_extrude() translate(20) circle(10);"- totalRot :: ℝ <- argument "a" `defaultTo` 360 `doc` "angle to sweep" r :: ℝ <- argument "r" `defaultTo` 0 translateArg :: Either ℝ2 (ℝ -> ℝ2) <- argument "translate" `defaultTo` Left (0,0) rotateArg :: Either ℝ (ℝ -> ℝ ) <- argument "rotate" `defaultTo` Left 0- let- is360m :: RealFrac a => a -> Bool+ is360m :: ℝ -> 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 capM = if cap then Just r else Nothing-- return $ return $ obj2UpMap (Prim.rotateExtrude totalRot capM translateArg rotateArg) children----{-rotateExtrudeStatement = moduleWithSuite "rotate_extrude" $ \suite -> do- h <- realArgument "h"- center <- boolArgumentWithDefault "center" False- twist <- realArgumentWithDefault 0.0- r <- realArgumentWithDefault "r" 0.0- getAndModUpObj2s suite (\obj -> extrudeRMod r (\θ (x,y) -> (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ)) ) obj h)--}+ pure $ pure $ obj2UpMap (Prim.rotateExtrude totalRot capM translateArg rotateArg) children -shell :: (String, [OVal] -> ArgParser (IO [OVal]))-shell = moduleWithSuite "shell" $ \children-> do+shell :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+shell = moduleWithSuite "shell" $ \_ children -> do w :: ℝ <- argument "w" `doc` "width of the shell..."-- return $ return $ objMap (Prim.shell w) (Prim.shell w) children---- Not a perenant solution! Breaks if can't pack.-pack :: (String, [OVal] -> ArgParser (IO [OVal]))-pack = moduleWithSuite "pack" $ \children -> do+ pure $ pure $ objMap (Prim.shell w) (Prim.shell w) children +-- Not a permanent solution! Breaks if can't pack.+pack :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+pack = moduleWithSuite "pack" $ \sourcePosition children -> do example "pack ([45,45], sep=2) { circle(10); circle(10); circle(10); circle(10); }"- -- arguments size :: ℝ2 <- argument "size" `doc` "size of 2D box to pack objects within" sep :: ℝ <- argument "sep" `doc` "mandetory space between objects"- -- The actual work...- return $+ pure $ let (obj2s, obj3s, others) = divideObjs children in if not $ null obj3s then case Prim.pack3 size sep obj3s of- Just solution -> return $ OObj3 solution : (map OObj2 obj2s ++ others)+ Just solution -> pure $ OObj3 solution : (fmap OObj2 obj2s <> others) Nothing -> do- putStrLn "Can't pack given objects in given box with present algorithm"- return children+ errorC sourcePosition "Can't pack given objects in given box with the present algorithm."+ pure children else case Prim.pack2 size sep obj2s of- Just solution -> return $ OObj2 solution : others+ Just solution -> pure $ OObj2 solution : others Nothing -> do- putStrLn "Can't pack given objects in given box with present algorithm"- return children--unit :: (String, [OVal] -> ArgParser (IO [OVal]))-unit = moduleWithSuite "unit" $ \children -> do+ errorC sourcePosition "Can't pack given objects in given box with the present algorithm."+ pure children +unit :: (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+unit = moduleWithSuite "unit" $ \sourcePosition children -> do example "unit(\"inch\") {..}"- -- arguments name :: String <- argument "unit" `doc` "the unit you wish to work in"- let- mmRatio :: Fractional a => String -> Maybe a+ mmRatio :: String -> Maybe ℝ mmRatio "inch" = Just 25.4 mmRatio "in" = mmRatio "inch" mmRatio "foot" = Just 304.8@@ -475,32 +529,32 @@ mmRatio "um" = mmRatio "µm" mmRatio "nm" = Just 0.0000001 mmRatio _ = Nothing- -- The actual work...- return $ case mmRatio name of+ pure $ case mmRatio name of Nothing -> do- putStrLn $ "unrecognized unit " ++ name- return children+ errorC sourcePosition $ "unrecognized unit " <> name+ pure children Just r ->- return $ objMap (Prim.scale (r,r)) (Prim.scale (r,r,r)) children+ pure $ objMap (Prim.scale (r,r)) (Prim.scale (r,r,r)) children --------------- (<|>) :: ArgParser a -> ArgParser a -> ArgParser a-(<|>) = Monad.mplus+(<|>) = mplus -moduleWithSuite :: t -> t1 -> (t, t1)-moduleWithSuite name modArgMapper = (name, modArgMapper)-moduleWithoutSuite :: t -> a -> (t, b -> a)-moduleWithoutSuite name modArgMapper = (name, const modArgMapper)+moduleWithSuite :: String -> (SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -> (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+moduleWithSuite name modArgMapper = (Symbol name, modArgMapper) -addObj3 :: SymbolicObj3 -> ArgParser (IO [OVal])-addObj3 x = return $ return [OObj3 x]+moduleWithoutSuite :: String -> (SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) -> (Symbol, SourcePosition -> [OVal] -> ArgParser (StateC [OVal]))+moduleWithoutSuite name modArgMapper = (Symbol name, modArgMapper) -addObj2 :: SymbolicObj2 -> ArgParser (IO [OVal])-addObj2 x = return $ return [OObj2 x]+addObj2 :: SymbolicObj2 -> ArgParser (StateC [OVal])+addObj2 x = pure $ pure [OObj2 x] +addObj3 :: SymbolicObj3 -> ArgParser (StateC [OVal])+addObj3 x = pure $ pure [OObj3 x]+ objMap :: (SymbolicObj2 -> SymbolicObj2) -> (SymbolicObj3 -> SymbolicObj3) -> [OVal] -> [OVal] objMap obj2mod obj3mod (x:xs) = case x of OObj2 obj2 -> OObj2 (obj2mod obj2) : objMap obj2mod obj3mod xs@@ -521,7 +575,7 @@ a -> a : obj2UpMap obj2upmod xs obj2UpMap _ [] = [] -toInterval :: Fractional t => Bool -> t -> (t, t)+toInterval :: Bool -> ℝ -> ℝ2 toInterval center h = if center then (-h/2, h/2)
Graphics/Implicit/ExtOpenScad/Util/ArgParser.hs view
@@ -2,59 +2,67 @@ -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}- -- FIXME: why is this required? {-# LANGUAGE ScopedTypeVariables #-} module Graphics.Implicit.ExtOpenScad.Util.ArgParser (argument, doc, defaultTo, example, test, eulerCharacteristic, argMap) where -import Prelude(String, Maybe(Just, Nothing), ($), (++), concat, show, error, return, map, snd, filter, (.), fst, foldl1, not, null, (&&))+-- imported twice, once qualified. null from Data.Map conflicts with null from Prelude.+import Prelude(String, Maybe(Just, Nothing), ($), (<>), show, error, return, fmap, snd, filter, (.), fst, foldl1, not, (&&), (<$>))+import qualified Prelude as P (null) -import Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch, APTerminator, APFailIf, APExample), OVal (OError), TestInvariant(EulerCharacteristic))+import Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch, APTerminator, APFailIf, APExample), OVal (OError), TestInvariant(EulerCharacteristic), Symbol, VarLookup(VarLookup))+ import Graphics.Implicit.ExtOpenScad.Util.OVal (fromOObj, toOObj, OTypeMirror) import Graphics.Implicit.Definitions(ℕ) -import qualified Data.Map as Map+-- imported twice, once qualified. null from Data.Map conflicts with null from Prelude.+import Data.Map (fromList, lookup, delete)+import qualified Data.Map as DM (null)+ import Data.Maybe (isNothing, fromJust, isJust) -import Control.Arrow(first)+import Data.Foldable (fold) +import Control.Arrow (first)+ -- * ArgParser building functions -- ** argument and combinators -argument :: forall desiredType. (OTypeMirror desiredType) => String -> ArgParser desiredType+-- | Builds an argparser for the type that is expected from it.+-- FIXME: make a version of this that accepts multiple symbol names, so we can have h= and height=+argument :: forall desiredType. (OTypeMirror desiredType) => Symbol -> ArgParser desiredType argument name = AP name Nothing "" $ \oObjVal -> do let val :: Maybe desiredType val = fromOObj oObjVal errmsg = case oObjVal of- OError errs -> "error in computing value for arugment " ++ name- ++ ": " ++ concat errs- _ -> "arg " ++ show oObjVal ++ " not compatible with " ++ name+ OError errs -> "error in computing value for argument " <> show name+ <> ": " <> fold errs+ _ -> "arg " <> show oObjVal <> " not compatible with " <> show name -- Using /= Nothing would require Eq desiredType APFailIf (isNothing val) errmsg $ APTerminator $ fromJust val+{-# INLINABLE argument #-} +-- | Inline documentation. doc :: forall a. ArgParser a -> String -> ArgParser a doc (AP name defMaybeVal _ next) newDoc = AP name defMaybeVal newDoc next doc _ _ = error "Impossible!" +-- | An inline default value. defaultTo :: forall a. (OTypeMirror a) => ArgParser a -> a -> ArgParser a defaultTo (AP name _ doc' next) newDefVal = AP name (Just $ toOObj newDefVal) doc' next defaultTo _ _ = error "Impossible!" --- ** example-+-- | An inline example. example :: String -> ArgParser () example str = APExample str (return ()) --- * test and combinators-+-- | Inline test and combinators. test :: String -> ArgParser () test str = APTest str [] (return ()) @@ -66,42 +74,42 @@ -- * Tools for handeling ArgParsers -- | Apply arguments to an ArgParser- argMap ::- [(Maybe String, OVal)] -- ^ arguments+ [(Maybe Symbol, OVal)] -- ^ arguments -> ArgParser a -- ^ ArgParser to apply them to -> (Maybe a, [String]) -- ^ (result, error messages)--argMap args = argMap2 unnamedArgs (Map.fromList namedArgs) where- unnamedArgs = map snd $ filter (isNothing . fst) args- namedArgs = map (first fromJust) $ filter (isJust . fst) args---argMap2 :: [OVal] -> Map.Map String OVal -> ArgParser a -> (Maybe a, [String])+argMap args = argMap2 unnamedArgs (VarLookup $ fromList namedArgs) where+ unnamedArgs = snd <$> filter (isNothing . fst) args+ namedArgs = first fromJust <$> filter (isJust . fst) args -argMap2 uArgs nArgs (APBranch branches) =+argMap2 :: [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])+argMap2 unnamedArgs namedArgs (APBranch branches) = foldl1 merge solutions where- solutions = map (argMap2 uArgs nArgs) branches- merge :: forall t t1. (Maybe t, [t1]) -> (Maybe t, [t1]) -> (Maybe t, [t1])+ solutions = fmap (argMap2 unnamedArgs namedArgs) branches+ merge :: forall a. (Maybe a, [String]) -> (Maybe a, [String]) -> (Maybe a, [String]) merge a@(Just _, []) _ = a merge _ b@(Just _, []) = b merge a@(Just _, _) _ = a merge (Nothing, _) a = a -argMap2 unnamedArgs namedArgs (AP name fallback _ f) =- case Map.lookup name namedArgs of+-- FIXME: don't use delete directly here, wrap it in StateC.hs+-- FIXME: generate a warning.+argMap2 unnamedArgs (VarLookup namedArgs) (AP name fallback _ f) =+ case lookup name namedArgs of Just a -> argMap2 unnamedArgs- (Map.delete name namedArgs)+ (VarLookup $ delete name namedArgs) (f a) Nothing -> case unnamedArgs of- x:xs -> argMap2 xs namedArgs (f x)+ x:xs -> argMap2 xs (VarLookup namedArgs) (f x) [] -> case fallback of- Just b -> argMap2 [] namedArgs (f b)- Nothing -> (Nothing, ["No value and no default for argument " ++ name])+ Just b -> argMap2 [] (VarLookup namedArgs) (f b)+ Nothing -> (Nothing, ["No value and no default for argument " <> show name]) -argMap2 a b (APTerminator val) =- (Just val, ["unused arguments" | not (null a && Map.null b)])+-- FIXME: don't use map.null here, wrap it in StateC.hs.+-- FIXME: generate a warning.+argMap2 a (VarLookup b) (APTerminator val) =+ (Just val, ["Unused arguments" | not (P.null a && DM.null b)]) argMap2 a b (APFailIf testval err child) = if testval
Graphics/Implicit/ExtOpenScad/Util/OVal.hs view
@@ -4,21 +4,25 @@ -- FIXME: required. why? {-# LANGUAGE ViewPatterns #-}+ {-# LANGUAGE ScopedTypeVariables #-}+ {-# LANGUAGE TypeSynonymInstances #-} 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), Char, String, (==), fromInteger, floor, ($), (.), map, error, (++), show, fromIntegral, head, flip, filter, not, return, head)+import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left,Right), Char, String, (==), fromInteger, floor, ($), (.), fmap, error, (<>), show, head, flip, filter, not, return, head) -import Graphics.Implicit.Definitions(ℝ, ℕ, SymbolicObj2, SymbolicObj3)+import Graphics.Implicit.Definitions(ℝ, ℕ, SymbolicObj2, SymbolicObj3, fromℕtoℝ) -import Graphics.Implicit.ExtOpenScad.Definitions (OVal(ONum, OBool, OString, OList, OFunc, OUndefined, OModule, OError, OObj2, OObj3))+import Graphics.Implicit.ExtOpenScad.Definitions (OVal(ONum, OBool, OString, OList, OFunc, OUndefined, OUModule, ONModule, OVargsModule, OError, OObj2, OObj3)) -import Control.Monad (mapM, msum)+import Control.Monad (msum) import Data.Maybe (fromMaybe, maybe) +import Data.Traversable(traverse)+ -- for some minimal paralellism. import Control.Parallel.Strategies(runEval, rpar, rseq) @@ -26,27 +30,32 @@ class OTypeMirror a where fromOObj :: OVal -> Maybe a fromOObjList :: OVal -> Maybe [a]- fromOObjList (OList list) = mapM fromOObj list+ fromOObjList (OList list) = traverse fromOObj list fromOObjList _ = Nothing+ {-# INLINABLE fromOObjList #-} toOObj :: a -> OVal instance OTypeMirror OVal where fromOObj = Just+ {-# INLINABLE fromOObj #-} toOObj a = a instance OTypeMirror ℝ where fromOObj (ONum n) = Just n fromOObj _ = Nothing+ {-# INLINABLE fromOObj #-} toOObj = ONum instance OTypeMirror ℕ where fromOObj (ONum n) = if n == fromInteger (floor n) then Just (floor n) else Nothing fromOObj _ = Nothing- toOObj a = ONum $ fromIntegral a+ {-# INLINABLE fromOObj #-}+ toOObj = ONum . fromℕtoℝ instance OTypeMirror Bool where fromOObj (OBool b) = Just b fromOObj _ = Nothing+ {-# INLINABLE fromOObj #-} toOObj = OBool -- We don't actually use single chars, this is to compile lists of chars (AKA strings) after passing through OTypeMirror [a]'s fromOObj.@@ -54,28 +63,33 @@ instance OTypeMirror Char where fromOObj (OString str) = Just $ head str fromOObj _ = Nothing+ {-# INLINABLE fromOObj #-} fromOObjList (OString str) = Just str fromOObjList _ = Nothing toOObj a = OString [a] instance (OTypeMirror a) => OTypeMirror [a] where fromOObj = fromOObjList- toOObj list = OList $ map toOObj list+ {-# INLINABLE fromOObj #-}+ toOObj list = OList $ fmap toOObj list instance (OTypeMirror a) => OTypeMirror (Maybe a) where fromOObj a = Just $ fromOObj a+ {-# INLINABLE fromOObj #-} toOObj (Just a) = toOObj a toOObj Nothing = OUndefined instance (OTypeMirror a, OTypeMirror b) => OTypeMirror (a,b) where fromOObj (OList [fromOObj -> Just a,fromOObj -> Just b]) = Just (a,b) fromOObj _ = Nothing+ {-# INLINABLE fromOObj #-} toOObj (a,b) = OList [toOObj a, toOObj b] 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+ {-# INLINABLE fromOObj #-} toOObj (a,b,c) = OList [toOObj a, toOObj b, toOObj c] instance (OTypeMirror a, OTypeMirror b) => OTypeMirror (a -> b) where@@ -87,8 +101,9 @@ output = fromOObj oOutput in fromMaybe (error $ "coercing OVal to a -> b isn't always safe; use a -> Maybe b"- ++ " (trace: " ++ show oInput ++ " -> " ++ show oOutput ++ " )") output+ <> " (trace: " <> show oInput <> " -> " <> show oOutput <> " )") output fromOObj _ = Nothing+ {-# INLINABLE fromOObj #-} toOObj f = OFunc $ \oObj -> case fromOObj oObj :: Maybe a of Nothing -> OError ["bad input type"]@@ -98,39 +113,42 @@ fromOObj (fromOObj -> Just (x :: a)) = Just $ Left x fromOObj (fromOObj -> Just (x :: b)) = Just $ Right x fromOObj _ = Nothing+ {-# INLINABLE fromOObj #-} toOObj (Right x) = toOObj x toOObj (Left x) = toOObj x -- A string representing each type. oTypeStr :: OVal -> String-oTypeStr OUndefined = "Undefined"-oTypeStr (OBool _ ) = "Bool"-oTypeStr (ONum _ ) = "Number"-oTypeStr (OList _ ) = "List"-oTypeStr (OString _ ) = "String"-oTypeStr (OFunc _ ) = "Function"-oTypeStr (OModule _ ) = "Module"-oTypeStr (OError _ ) = "Error"-oTypeStr (OObj2 _ ) = "2D Object"-oTypeStr (OObj3 _ ) = "3D Object"+oTypeStr OUndefined = "Undefined"+oTypeStr (OBool _ ) = "Bool"+oTypeStr (ONum _ ) = "Number"+oTypeStr (OList _ ) = "List"+oTypeStr (OString _ ) = "String"+oTypeStr (OFunc _ ) = "Function"+oTypeStr (OUModule _ _ _ ) = "User Defined Module"+oTypeStr (ONModule _ _ _ ) = "Built-in Module"+oTypeStr (OVargsModule _ _ ) = "VargsModule"+oTypeStr (OError _ ) = "Error"+oTypeStr (OObj2 _ ) = "2D Object"+oTypeStr (OObj3 _ ) = "3D Object" getErrors :: OVal -> Maybe String getErrors (OError er) = Just $ head er-getErrors (OList l) = msum $ map getErrors l+getErrors (OList l) = msum $ fmap getErrors l getErrors _ = Nothing -caseOType :: forall c a. a -> (a -> c) -> c+caseOType :: a -> (a -> c) -> c caseOType = flip ($) infixr 2 <||>-(<||>) :: forall desiredType out. (OTypeMirror desiredType)+(<||>) :: OTypeMirror desiredType => (desiredType -> out) -> (OVal -> out) -> (OVal -> out) (<||>) f g input = let- coerceAttempt :: Maybe desiredType+ coerceAttempt :: OTypeMirror desiredType => Maybe desiredType coerceAttempt = fromOObj input in maybe (g input) f coerceAttempt@@ -143,7 +161,7 @@ obj3s <- rseq [ x | OObj3 x <- children ] objs <- rpar (filter (not . isOObj) children) return (obj2s, obj3s, objs)- where- isOObj (OObj2 _) = True- isOObj (OObj3 _) = True- isOObj _ = False+ where+ isOObj (OObj2 _) = True+ isOObj (OObj3 _) = True+ isOObj _ = False
Graphics/Implicit/ExtOpenScad/Util/StateC.hs view
@@ -2,76 +2,76 @@ -- Copyright 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}+-- allow us to specify what package to import what module from.+-- We don't actually care, but when we compile our haskell examples, we do.+{-# LANGUAGE PackageImports #-} --- FIXME: required. why?-{-# LANGUAGE KindSignatures, FlexibleContexts #-}-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} -module Graphics.Implicit.ExtOpenScad.Util.StateC (getVarLookup, modifyVarLookup, lookupVar, pushVals, getVals, putVals, withPathShiftedBy, getPath, getRelPath, errorC, mapMaybeM, StateC) where+module Graphics.Implicit.ExtOpenScad.Util.StateC (addMessage, getVarLookup, modifyVarLookup, lookupVar, pushVals, getVals, putVals, withPathShiftedBy, getPath, getRelPath, errorC, warnC, scadOptions) where -import Prelude(FilePath, IO, String, Maybe(Just, Nothing), Show, Monad, fmap, (.), ($), (++), return, putStrLn, show)+import Prelude(FilePath, String, Maybe, ($), (<>), pure) -import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup, OVal)+import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup(VarLookup), OVal, Symbol, SourcePosition, Message(Message), MessageType(Error, Warning), ScadOpts, StateC, CompState(scadVars, oVals, sourceDir, messages, scadOpts)) -import qualified Data.Map as Map-import Control.Monad.State (StateT, get, put, modify, liftIO)-import System.FilePath((</>))-import Control.Monad.IO.Class (MonadIO)+import Data.Map (lookup) --- This is the state machine. It contains the variables, their values, the path, and... ?-type CompState = (VarLookup, [OVal], FilePath, (), ())-type StateC = StateT CompState IO+import "monads-tf" Control.Monad.State (modify, gets) +import System.FilePath((</>))+ getVarLookup :: StateC VarLookup-getVarLookup = fmap (\(a,_,_,_,_) -> a) get+getVarLookup = gets scadVars modifyVarLookup :: (VarLookup -> VarLookup) -> StateC ()-modifyVarLookup = modify . (\f (a,b,c,d,e) -> (f a, b, c, d, e))+modifyVarLookup f = modify $ \c -> c { scadVars = f $ scadVars c } -lookupVar :: String -> StateC (Maybe OVal)+-- | Perform a variable lookup+-- FIXME: generate a warning when we look up a variable that is not present.+lookupVar :: Symbol -> StateC (Maybe OVal) lookupVar name = do- varlookup <- getVarLookup- return $ Map.lookup name varlookup+ (VarLookup varlookup) <- getVarLookup+ pure $ lookup name varlookup pushVals :: [OVal] -> StateC ()-pushVals vals = modify (\(a,b,c,d,e) -> (a, vals ++ b,c,d,e))+pushVals vals = modify $ \c -> c { oVals = vals <> oVals c } getVals :: StateC [OVal]-getVals = do- (_,b,_,_,_) <- get- return b+getVals = gets oVals putVals :: [OVal] -> StateC ()-putVals vals = do- (a,_,c,d,e) <- get- put (a,vals,c,d,e)+putVals vals = modify $ \c -> c { oVals = vals } withPathShiftedBy :: FilePath -> StateC a -> StateC a withPathShiftedBy pathShift s = do- (a,b,path,d,e) <- get- put (a, b, path </> pathShift, d, e)- x <- s- (a',b',_,d',e') <- get- put (a', b', path, d', e')- return x+ path <- getPath+ modify $ \c -> c { sourceDir = path </> pathShift }+ x <- s+ modify $ \c -> c { sourceDir = path }+ pure x +-- | Pure the path stored in the state. getPath :: StateC FilePath-getPath = do- (_,_,c,_,_) <- get- return c+getPath = gets sourceDir getRelPath :: FilePath -> StateC FilePath getRelPath relPath = do path <- getPath- return $ path </> relPath+ pure $ path </> relPath -errorC :: forall (m :: * -> *) a. (Show a, MonadIO m) => a -> String -> m ()-errorC lineN err = liftIO $ putStrLn $ "At " ++ show lineN ++ ": " ++ err+addMesg :: Message -> StateC ()+addMesg m = modify $ \c -> c { messages = messages c <> pure m } -mapMaybeM :: forall t (m :: * -> *) a. Monad m => (t -> m a) -> Maybe t -> m (Maybe a)-mapMaybeM f (Just a) = do- b <- f a- return (Just b)-mapMaybeM _ Nothing = return Nothing+addMessage :: MessageType -> SourcePosition -> String -> StateC ()+addMessage mtype pos text = addMesg $ Message mtype pos text++errorC :: SourcePosition -> String -> StateC ()+errorC = addMessage Error+{-# INLINABLE errorC #-}++warnC :: SourcePosition -> String -> StateC ()+warnC = addMessage Warning+{-# INLINABLE warnC #-}++scadOptions :: StateC ScadOpts+scadOptions = gets scadOpts+
+ Graphics/Implicit/FastIntUtil.hs view
@@ -0,0 +1,30 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Copyright 2014-2019, Julia Longtin (julial@turinglace.com)+-- Released under the GNU AGPLV3+, see LICENSE++-- Use existing instances for the wrapped types rather than manually manking them+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Graphics.Implicit.FastIntUtil (Fastℕ(Fastℕ), toFastℕ, fromFastℕ) where++import Prelude (Integral, Num, Eq, Ord, Enum, Real, Show, Read, Int, id)++class FastN n where+ fromFastℕ :: Fastℕ -> n+ toFastℕ :: n -> Fastℕ++instance FastN Int where+ fromFastℕ (Fastℕ a) = a+ {-# INLINABLE fromFastℕ #-}+ toFastℕ = Fastℕ+ {-# INLINABLE toFastℕ #-}++instance FastN Fastℕ where+ fromFastℕ = id+ {-# INLINABLE fromFastℕ #-}+ toFastℕ = id+ {-# INLINABLE toFastℕ #-}++-- System integers, meant to go fast, and have no chance of wrapping 2^31.+newtype Fastℕ = Fastℕ Int+ deriving (Show, Read, Eq, Ord, Num, Enum, Integral, Real)
+ Graphics/Implicit/IntegralUtil.hs view
@@ -0,0 +1,44 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Copyright 2014-2019, Julia Longtin (julial@turinglace.com)+-- Released under the GNU AGPLV3+, see LICENSE++-- Lift the numeric instances where we can+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- Suppress a warning about the derived Integral instance+{-# OPTIONS_GHC -Wno-identities #-}++module Graphics.Implicit.IntegralUtil (ℕ, toℕ, fromℕ) where++import Prelude (Integral, Integer, Int, Show, Read, Eq, Ord, Num, Enum, Integral, Real, ($), fromIntegral, (.))++-- So we can produce an instance of Fastℕ for ℕ.+import Graphics.Implicit.FastIntUtil (Fastℕ(Fastℕ))++-- the N typeclass. only used to define the ℕ type.+class (Integral n) => N n where+ fromℕ :: ℕ -> n+ toℕ :: n -> ℕ++instance N Integer where+ fromℕ (ℕ a) = a+ {-# INLINABLE fromℕ #-}+ toℕ = ℕ+ {-# INLINABLE toℕ #-}++instance N Fastℕ where+ fromℕ (ℕ a) = Fastℕ $ fromIntegral a+ {-# INLINABLE fromℕ #-}+ toℕ = ℕ . fromIntegral+ {-# INLINABLE toℕ #-}++instance N Int where+ fromℕ (ℕ a) = fromIntegral a+ {-# INLINABLE fromℕ #-}+ toℕ = ℕ . fromIntegral+ {-# INLINABLE toℕ #-}++-- Arbitrary precision integers. To be used for anything countable, or in ratios.+-- When Read and Show instances exist on a given type they need to satisfy+-- read . show = id+newtype ℕ = ℕ Integer+ deriving (Show, Read, Eq, Ord, Num, Enum, Integral, Real)
Graphics/Implicit/MathUtil.hs view
@@ -2,14 +2,11 @@ -- Copyright (C) 2014 2015 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}- -- A module of math utilities. 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, (++), head, flip)+import Prelude (Bool, Ordering, (>), (<), (+), ($), (/), otherwise, not, (||), (&&), abs, (-), (*), sin, asin, pi, max, sqrt, min, compare, (<=), fst, snd, (<>), head, flip, maximum, minimum, (==)) import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, Box2, (⋅)) @@ -26,8 +23,10 @@ where ab = b ^-^ a ap = p ^-^ a+ d :: ℝ d = normalized ab ⋅ ap -- the closest point to p on the line segment.+ closest :: ℝ2 closest | d < 0 = a | d > magnitude ab = b@@ -51,10 +50,11 @@ -> ℝ -- ^ first number to round maximum -> ℝ -- ^ second number to round maximum -> ℝ -- ^ resulting number-rmax r x y = if abs (x-y) < r- then y - r*sin(pi/4-asin((x-y)/r/sqrt 2)) + r- else max x y-+rmax r x y+ | r == 0 = max x y+ | otherwise = if abs (x-y) < r+ then y - r*sin(pi/4-asin((x-y)/r/sqrt 2)) + r+ else max x y -- | Rounded minimum rmin ::@@ -74,9 +74,14 @@ ℝ -- ^ radius -> [ℝ] -- ^ numbers to take round maximum -> ℝ -- ^ resulting number+rmaximum _ [] = 0 rmaximum _ [a] = a-rmaximum r [a,b] = rmax r a b-rmaximum r l =+rmaximum r [a,b]+ | r == 0 = max a b+ | otherwise = rmax r a b+rmaximum r l+ | r == 0 = maximum l+ | otherwise = let tops = sortBy (flip compare) l in@@ -87,13 +92,18 @@ ℝ -- ^ radius -> [ℝ] -- ^ numbers to take round minimum -> ℝ -- ^ resulting number+rminimum _ [] = 0 rminimum _ [a] = a-rminimum r [a,b] = rmin r a b-rminimum r l =+rminimum r [a,b]+ | r > 0 = rmin r a b+ | otherwise = min a b+rminimum r l+ | r > 0 = let tops = sort l in rmin r (head tops) (tops !! 1)+ | otherwise = minimum l -- | Pack the given objects in a box the given size. pack ::@@ -103,9 +113,9 @@ -> ([(ℝ2, a)], [(Box2, a)] ) -- ^ Packed objects with their positions, objects that could be packed pack (dx, dy) sep objs = packSome sortedObjs (dx, dy) where- compareBoxesByY :: forall t t1 t2 t3 a. (Ord a, Num a) => ((t, a), (t1, a)) -> ((t2, a), (t3, a)) -> Ordering+ compareBoxesByY :: Box2 -> Box2 -> Ordering compareBoxesByY ((_, ay1), (_, ay2)) ((_, by1), (_, by2)) =- compare (abs $ by2-by1) (abs $ ay2 - ay1)+ compare (abs $ by2-by1) (abs $ ay2-ay1) sortedObjs = sortBy (\(boxa, _) (boxb, _) -> compareBoxesByY boxa boxb )@@ -125,7 +135,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.hs view
@@ -2,11 +2,9 @@ -- Copyright (C) 2014 2015 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- create a module that is just wrapping up these functions.+-- create a module that just wraps the functions in the ObjectUtil directory. module Graphics.Implicit.ObjectUtil(getImplicit3, getImplicit2, getBox3, getBox2) where--import Prelude() import Graphics.Implicit.ObjectUtil.GetImplicit3 (getImplicit3)
Graphics/Implicit/ObjectUtil/GetBox2.hs view
@@ -2,24 +2,28 @@ -- Copyright 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}--module Graphics.Implicit.ObjectUtil.GetBox2 (getBox2, getDist2) where+module Graphics.Implicit.ObjectUtil.GetBox2 (getBox2, getBox2R) where -import Prelude(Bool, Fractional, (==), (||), unzip, minimum, maximum, ($), filter, not, (.), (/), map, (-), (+), (*), cos, sin, sqrt, min, max, abs, head)+import Prelude(Bool, Fractional, Eq, (==), (||), unzip, minimum, maximum, ($), filter, not, (.), (/), fmap, (-), (+), (*), cos, sin, sqrt, min, max, head, (<), (<>), pi, atan2, (==), (>), show, (&&), otherwise, error) import Graphics.Implicit.Definitions (ℝ, ℝ2, Box2, (⋯*), SymbolicObj2(Shell2, Outset2, Circle, Translate2, Rotate2, UnionR2, Scale2, RectR,- PolygonR, Complement2, DifferenceR2, IntersectR2, EmbedBoxedObj2))+ PolygonR, Complement2, DifferenceR2, IntersectR2, EmbedBoxedObj2), minℝ) -import Data.VectorSpace (magnitude, (^-^), (^+^))+import Data.VectorSpace ((^-^), (^+^)) --- Is a Box2 empty?--- Really, this checks if it is one dimensional, which is good enough.+import Data.Fixed (mod')++-- | An empty box.+emptyBox :: Box2+emptyBox = ((0, 0), (0, 0))++-- | Is a Box2 empty?+-- | Really, this checks if it is one dimensional, which is good enough. isEmpty :: Box2 -> Bool isEmpty ((a, b), (c, d)) = a==c || b==d --- Define a Box2 around all of the given points.+-- | Define a Box2 around all of the given points. pointsBox :: [ℝ2] -> Box2 pointsBox points = let@@ -27,6 +31,11 @@ in ((minimum xs, minimum ys), (maximum xs, maximum ys)) +-- | Decompose a box into it's four corners.+boxPoints :: Box2 -> [ℝ2]+boxPoints ((x1,y1),(x2,y2)) = [(x1,y1), (x1,y2), (x2,y1), (x2,y2)]++-- | Define a Box2 around all of the given boxes. unionBoxes :: [Box2] -> Box2 unionBoxes boxes = let@@ -36,15 +45,28 @@ in ((minimum lefts, minimum bots), (maximum rights, maximum tops)) +-- | Define a Box2 that is the intersection of all of the given Box2s.+intersectBoxes :: [Box2] -> Box2+intersectBoxes [] = emptyBox+intersectBoxes [x] = x+intersectBoxes (x:xs) = if nmaxx > nminx && nmaxy > nminy+ then ((nminx, nminy), (nmaxx, nmaxy))+ else emptyBox+ where+ ((nminx, nminy), (nmaxx, nmaxy)) = ((max xmin1 xmin2, max ymin1 ymin2), (min xmax1 xmax2, min ymax1 ymax2)) + ((xmin1, ymin1), (xmax1, ymax1)) = x+ ((xmin2, ymin2), (xmax2, ymax2)) = intersectBoxes xs++-- | Increase a boxes size by a rounding value. outsetBox :: ℝ -> Box2 -> Box2 outsetBox r (a,b) = (a ^-^ (r,r), b ^+^ (r,r)) --- Define a Box2 around the given object.+-- Get a Box2 around the given object. getBox2 :: SymbolicObj2 -> Box2 -- Primitives getBox2 (RectR _ a b) = (a,b)-getBox2 (Circle r ) = ((-r, -r), (r,r))+getBox2 (Circle r) = ((-r, -r), (r,r)) getBox2 (PolygonR _ points) = pointsBox points -- (Rounded) CSG getBox2 (Complement2 _) =@@ -53,27 +75,17 @@ infty :: (Fractional t) => t infty = 1/0 getBox2 (UnionR2 r symbObjs) =- outsetBox r $ unionBoxes (map getBox2 symbObjs)+ outsetBox r $ unionBoxes (fmap getBox2 symbObjs) getBox2 (DifferenceR2 _ symbObjs) = getBox2 $ head symbObjs getBox2 (IntersectR2 r symbObjs) =- let- boxes = map getBox2 symbObjs- (leftbot, topright) = unzip boxes- (lefts, bots) = unzip leftbot- (rights, tops) = unzip topright- left = maximum lefts- bot = maximum bots- right = minimum rights- top = minimum tops- in- ((left-r,bot-r),(right+r,top+r))+ outsetBox r $ intersectBoxes $ filter (not.isEmpty) $ fmap getBox2 symbObjs -- Simple transforms getBox2 (Translate2 v symbObj) = let (a,b) = getBox2 symbObj in if isEmpty (a,b)- then ((0,0),(0,0))+ then emptyBox else (a^+^v, b^+^v) getBox2 (Scale2 s symbObj) = let@@ -100,29 +112,223 @@ -- Misc getBox2 (EmbedBoxedObj2 (_,box)) = box --- 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--- 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))- )+-- | Define a Box2 around the given object, and the space it occupies while rotating about the center point.+-- Note: No implementations for RectR, Translate2, or Scale2 as they would be identical to the fallthrough.+getBox2R :: SymbolicObj2 -> ℝ -> Box2+getBox2R (Circle r) _ = getBox2 $ Circle r+getBox2R (PolygonR _ points) deg =+ let+ pointRBoxes = [ pointRBox point deg | point <- points ]+ (pointValsMin, pointValsMax) = unzip pointRBoxes+ (pointValsX, pointValsY) = unzip (pointValsMin <> pointValsMax)+ in+ ((minimum pointValsX, minimum pointValsY), (maximum pointValsX, maximum pointValsY))+getBox2R (Complement2 symObj) _ = getBox2 $ Complement2 symObj+getBox2R (UnionR2 r symObjs) deg =+ let+ boxes = [ getBox2R obj deg| obj <- symObjs ]+ in+ outsetBox r $ unionBoxes boxes+getBox2R (DifferenceR2 _ symObjs) deg = getBox2R (head symObjs) deg+getBox2R (IntersectR2 r symObjs) deg =+ let+ boxes = [ getBox2R obj deg| obj <- symObjs ]+ in+ outsetBox r $ intersectBoxes boxes+-- FIXME: implement Rotate2.+-- Fallthrough: rotate the points of the containing box. no rounding.+getBox2R symObj deg =+ let+ origBox = getBox2 symObj+ points = boxPoints origBox+ in+ getBox2R (PolygonR 0 points) deg++data Quadrant = UpperRight | UpperLeft | LowerRight | LowerLeft+ deriving Eq+data Axis = PosX | PosY | NegX | NegY+ deriving Eq+data Position = OnAxis Axis | InQuadrant Quadrant | CenterPoint+data HasRotation = Rotation Direction | None+ deriving Eq+data Direction = Clockwise | CounterClockwise+ deriving Eq++-- | put a box around a point, and all of the locations it will be at during an x degree arc around (0,0).+pointRBox :: ℝ2 -> ℝ -> Box2+pointRBox (xStart, yStart) travel =+ let+ k :: ℝ+ k = pi/180+ -- distance betwen (0,0) and our target.+ distance = sqrt $ xStart*xStart + yStart*yStart+ -- radian starting position.+ θstart = atan2 yStart xStart+ -- logical starting position+ startPosition = positionOf distance $ absrad θstart+ -- how far we should rotate our point.+ rotationAmount = travel * k+ -- what direction are we rotating.+ rotationDirection = case travel of+ polarity | polarity > 0 -> Rotation CounterClockwise+ | polarity == 0 -> None+ _ -> Rotation Clockwise+ -- stopping position of our point.+ θstop = absrad $ θstart + rotationAmount+ stopPosition = positionOf distance θstop+ (xStop, yStop) =+ case positionOf distance θstop of+ CenterPoint -> (0,0)+ OnAxis PosX -> (distance,0)+ OnAxis PosY -> (0,distance)+ OnAxis NegX -> (-distance,0)+ OnAxis NegY -> (0,-distance)+ InQuadrant _ -> ( distance*cos θstop, distance*sin θstop)+ (minX, minY, maxX, maxY) = (min xStart xStop, min yStart yStop, max xStart xStop, max yStart yStop)+ positionOf :: ℝ -> ℝ -> Position+ positionOf d θpos+ | d < minℝ = CenterPoint+ | θpos == 0 || θpos == 360*k = OnAxis PosX+ | θpos == 90*k = OnAxis PosY+ | θpos == 180*k || θpos == -0 = OnAxis NegX+ | θpos == 270*k = OnAxis NegY+ | θpos > 0 && θpos < 90*k = InQuadrant UpperRight+ | θpos > 90*k && θpos < 180*k = InQuadrant UpperLeft+ | θpos > 180*k && θpos < 270*k = InQuadrant LowerLeft+ | θpos > 270*k && θpos < 360*k = InQuadrant LowerRight+ | otherwise = error $ "illegal position in positionOf: " <> show (θpos*k) <> " pos: " <> show θpos <> " d: " <> show d+ -- returns position around a circle in radians, from 0 to 2pi.+ absrad :: ℝ -> ℝ+ absrad rad+ | rad > (360*k) = rad `mod'` (360*k)+ | rad < 0 = absrad (360*k)+rad+ | otherwise = rad+ noAxis :: Quadrant -> Quadrant -> Direction -> ℝ -> Box2+ noAxis q1 q2 dir amount+ | q1 == q2 && amount < 90*k && amount > -90*k = ((minX, minY), (maxX, maxY))+ | dir == Clockwise && q1 == UpperLeft = oneAxis PosY q2 dir amount+ | dir == Clockwise && q1 == LowerRight = oneAxis PosX q2 dir amount+ | dir == Clockwise && q1 == LowerLeft = oneAxis NegY q2 dir amount+ | dir == Clockwise && q1 == UpperRight = oneAxis NegX q2 dir amount+ | dir == CounterClockwise && q1 == UpperRight = oneAxis PosX q2 dir amount+ | dir == CounterClockwise && q1 == UpperLeft = oneAxis PosY q2 dir amount+ | dir == CounterClockwise && q1 == LowerLeft = oneAxis NegX q2 dir amount+ | dir == CounterClockwise && q1 == LowerRight = oneAxis NegY q2 dir amount+ noAxis _ _ _ _ = ((-distance, -distance), (distance, distance))+ oneAxis :: Axis -> Quadrant -> Direction -> ℝ -> Box2+ oneAxis axis quadrant dir amount+ | dir == Clockwise &&+ amount < 90*k && amount > -90*k &&+ ((axis == PosX && quadrant == LowerRight) ||+ (axis == NegY && quadrant == LowerLeft) ||+ (axis == NegX && quadrant == UpperLeft) ||+ (axis == PosY && quadrant == UpperRight)) = ((minX, minY), (maxX, maxY))+ | dir == CounterClockwise &&+ amount < 90*k && amount > -90*k &&+ ((axis == PosX && quadrant == UpperRight) ||+ (axis == PosY && quadrant == UpperLeft) ||+ (axis == NegX && quadrant == LowerLeft) ||+ (axis == NegY && quadrant == LowerRight)) = ((minX, minY), (maxX, maxY))+ | dir == Clockwise &&+ ((axis == PosX && quadrant == LowerLeft) ||+ (axis == NegY && quadrant == UpperLeft) ||+ (axis == NegX && quadrant == UpperRight) ||+ (axis == PosY && quadrant == LowerRight)) = crossOne axis dir+ | dir == CounterClockwise &&+ ((axis == PosX && quadrant == UpperLeft) ||+ (axis == PosY && quadrant == LowerLeft) ||+ (axis == NegX && quadrant == LowerRight) ||+ (axis == NegY && quadrant == UpperRight)) = crossOne axis dir+ | dir == Clockwise &&+ ((axis == PosX && quadrant == UpperLeft) ||+ (axis == PosY && quadrant == LowerLeft) ||+ (axis == NegX && quadrant == LowerRight) ||+ (axis == NegY && quadrant == UpperRight)) = crossTwo axis dir+ | dir == CounterClockwise &&+ ((axis == PosX && quadrant == LowerLeft) ||+ (axis == NegY && quadrant == UpperLeft) ||+ (axis == NegX && quadrant == UpperRight) ||+ (axis == PosY && quadrant == LowerRight)) = crossTwo axis dir+ | dir == Clockwise &&+ ((axis == PosX && quadrant == UpperRight) ||+ (axis == PosY && quadrant == UpperLeft) ||+ (axis == NegX && quadrant == LowerLeft) ||+ (axis == NegY && quadrant == LowerRight)) = crossThree axis+ | dir == CounterClockwise &&+ ((axis == PosX && quadrant == LowerRight) ||+ (axis == NegY && quadrant == LowerLeft) ||+ (axis == NegX && quadrant == UpperLeft) ||+ (axis == PosY && quadrant == UpperRight)) = crossThree axis+ | otherwise = ((-distance, -distance), (distance, distance))+ twoAxis :: Axis -> Axis -> Direction -> Box2+ twoAxis start stop dir+ | (start == PosX && stop == NegX) ||+ (start == PosY && stop == NegY) || + (start == NegX && stop == PosX) ||+ (start == NegY && stop == PosY) = crossOne start dir+ twoAxis start stop dir+ | (start == PosX && stop == NegY) ||+ (start == NegY && stop == NegX) ||+ (start == NegX && stop == PosY) ||+ (start == PosY && stop == PosX) = if dir == Clockwise+ then ((minX, minY), (maxX, maxY))+ else crossTwo start dir+ | (start == PosX && stop == PosY) ||+ (start == PosY && stop == NegX) ||+ (start == NegX && stop == NegY) ||+ (start == NegY && stop == PosX) = if dir == CounterClockwise+ then ((minX, minY), (maxX, maxY))+ else crossTwo start dir+ twoAxis _ _ _ = ((-distance, -distance), (distance, distance))+ crossOne :: Axis -> Direction -> Box2+ crossOne start dir+ | (start == PosX && dir == Clockwise) ||+ (start == NegX && dir == CounterClockwise) = mixWith [(0,-distance)]+ | (start == NegY && dir == Clockwise) ||+ (start == PosY && dir == CounterClockwise) = mixWith [(-distance, 0)]+ | (start == NegX && dir == Clockwise) ||+ (start == PosX && dir == CounterClockwise) = mixWith [(0, distance)]+ | (start == PosY && dir == Clockwise) ||+ (start == NegY && dir == CounterClockwise) = mixWith [( distance, 0)]+ | otherwise = ((-distance, -distance), (distance, distance))+ crossTwo :: Axis -> Direction -> Box2+ crossTwo start dir+ | (start == PosX && dir == Clockwise) ||+ (start == PosY && dir == CounterClockwise) = mixWith [(-distance, 0), ( 0,-distance)]+ | (start == PosY && dir == Clockwise) ||+ (start == NegX && dir == CounterClockwise) = mixWith [( distance, 0), ( 0,-distance)]+ | (start == NegX && dir == Clockwise) ||+ (start == NegY && dir == CounterClockwise) = mixWith [( distance, 0), ( 0, distance)]+ | (start == NegY && dir == Clockwise) ||+ (start == PosX && dir == CounterClockwise) = mixWith [(-distance, 0), ( 0, distance)]+ | otherwise = ((-distance, -distance), (distance, distance))+ crossThree :: Axis -> Box2+ crossThree PosX = mixWith [( 0, distance), (-distance, 0), ( 0,-distance)]+ crossThree PosY = mixWith [(-distance, 0), ( 0,-distance), ( distance, 0)]+ crossThree NegX = mixWith [( 0,-distance), ( distance, 0), ( 0, distance)]+ crossThree NegY = mixWith [( distance, 0), ( 0, distance), (-distance, 0)]+ mixWith :: [ℝ2] -> Box2+ mixWith points = ((minimum xPoints, minimum yPoints), (maximum xPoints, maximum yPoints))+ where+ (xPoints, yPoints) = unzip $ points <> [(xStart, yStart), (xStop, yStop)] + invertRotation :: Direction -> Direction+ invertRotation Clockwise = CounterClockwise+ invertRotation CounterClockwise = Clockwise+ in+ case rotationDirection of+ None -> ((xStart, yStart),(xStart, yStart))+ Rotation dir -> case rotationAmount of+ amount | amount < 360*k && amount > -360*k ->+ case startPosition of+ CenterPoint -> emptyBox+ OnAxis axis -> case stopPosition of+ OnAxis stopaxis -> twoAxis axis stopaxis dir+ InQuadrant stopquadrant -> oneAxis axis stopquadrant dir amount+ CenterPoint -> emptyBox+ InQuadrant quadrant -> case stopPosition of+ OnAxis stopaxis -> oneAxis stopaxis quadrant (invertRotation dir) (-amount)+ InQuadrant stopquadrant -> noAxis quadrant stopquadrant dir travel+ CenterPoint -> emptyBox+ _ ->+ ((-distance, -distance), (distance, distance))
Graphics/Implicit/ObjectUtil/GetBox3.hs view
@@ -3,24 +3,29 @@ -- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com) -- Released under the GNU AGPLV3+, see LICENSE --- FIXME: required. why?-{-# 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, otherwise)+import Prelude(Eq, Bool(False), Fractional, Either (Left, Right), (==), (||), max, (/), (-), (+), fmap, unzip, ($), filter, not, (.), unzip3, minimum, maximum, min, (>), (&&), head, (*), (<), abs, either, error, const, otherwise, take, fst, snd) -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)+import Graphics.Implicit.Definitions (ℝ, Fastℕ, Box3, SymbolicObj3 (Rect3R, Sphere, Cylinder, Complement3, UnionR3, IntersectR3, DifferenceR3, Translate3, Scale3, Rotate3, Rotate3V, Shell3, Outset3, EmbedBoxedObj3, ExtrudeR, ExtrudeOnEdgeOf, ExtrudeRM, RotateExtrude, ExtrudeRotateR), SymbolicObj2 (Rotate2, RectR), (⋯*), fromFastℕtoℝ, fromFastℕ) -import Data.Maybe (fromMaybe)+import Graphics.Implicit.ObjectUtil.GetBox2 (getBox2, getBox2R)+ import Data.VectorSpace ((^-^), (^+^)) --- test to see whether a Box3 has area.+-- FIXME: many variables are being ignored here. no rounding for intersect, or difference.. etc.++-- | An empty box.+emptyBox :: Box3+emptyBox = ((0,0,0), (0,0,0))++-- | Is a Box3 empty?+-- | Really, this checks if it is one dimensional, which is good enough. isEmpty :: (Eq a2, Eq a1, Eq a) => ((a, a1, a2), (a, a1, a2)) -> Bool isEmpty ((a,b,c),(d,e,f)) = a==d || b==e || c==f +-- | Increase a boxes size by a rounding value. outsetBox :: ℝ -> Box3 -> Box3 outsetBox r (a,b) = (a ^-^ (r,r,r), b ^+^ (r,r,r))@@ -37,9 +42,9 @@ where infty :: (Fractional t) => t infty = 1/0-getBox3 (UnionR3 r symbObjs) = ((left-r,bot-r,inward-r), (right+r,top+r,out+r))+getBox3 (UnionR3 r symbObjs) = outsetBox r ((left,bot,inward), (right,top,out)) where- boxes = map getBox3 symbObjs+ boxes = fmap getBox3 symbObjs (leftbot, topright) = unzip $ filter (not.isEmpty) boxes (lefts, bots, ins) = unzip3 leftbot (rights, tops, outs) = unzip3 topright@@ -49,9 +54,10 @@ right = maximum rights top = maximum tops out = maximum outs+getBox3 (DifferenceR3 _ symbObjs) = getBox3 $ head symbObjs getBox3 (IntersectR3 _ symbObjs) = let- boxes = map getBox3 symbObjs+ boxes = fmap getBox3 symbObjs (leftbot, topright) = unzip boxes (lefts, bots, ins) = unzip3 leftbot (rights, tops, outs) = unzip3 topright@@ -66,8 +72,7 @@ && right > left && out > inward then ((left,bot,inward),(right,top,out))- else ((0,0,0),(0,0,0))-getBox3 (DifferenceR3 _ symbObjs) = getBox3 $ head symbObjs+ else emptyBox -- Simple transforms getBox3 (Translate3 v symbObj) = let@@ -81,10 +86,17 @@ (sbx,sby,sbz) = s ⋯* b in ((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]+getBox3 (Rotate3 (a, b, c) symbObj) =+ let+ ((x1, y1, z1), (x2, y2, z2)) = getBox3 symbObj+ rotate v1 w1 v2 w2 angle = getBox2(Rotate2 angle $ RectR 0 (v1, w1) (v2, w2))+ ((y1', z1'), (y2', z2')) = rotate y1 z1 y2 z2 a+ ((z1'', x1'), (z2'', x2')) = rotate z1' x1 z2' x2 b+ ((x1'', y1''), (x2'', y2'')) = rotate x1' y1' x2' y2' c+ (xs, ys, zs) = ([x1'', x2''], [y1'', y2''], [z1'', z2''])+ in+ ((minimum xs, minimum ys, minimum zs), (maximum xs, maximum ys, maximum zs))+ getBox3 (Rotate3V _ v symbObj) = getBox3 (Rotate3 v symbObj) -- Boundary mods getBox3 (Shell3 w symbObj) =@@ -103,62 +115,92 @@ ((bx1,by1),(bx2,by2)) = getBox2 symbObj2 in ((bx1+ax1, by1+ax1, ay1), (bx2+ax2, by2+ax2, ay2))--- FIXME: magic numbers in range.-getBox3 (ExtrudeRM _ twist scale translate symbObj eitherh) =+-- FIXME: magic numbers: 0.2 and 11.+-- FIXME: this may use an approximation, based on sampling functions. generate a warning if the approximation part of this function is used.+-- FIXME: re-implement the expression system, so this can recieve a function, and determine class (constant, linear)... and implement better forms of this function.+getBox3 (ExtrudeRM _ twist scale translate symbObj height) = let- range :: [ℝ]- 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 ) - h = case eitherh of- Left h' -> h'- Right hf -> hmax + 0.2*(hmax-hmin)+ samples :: Fastℕ+ samples = 11+ range :: [Fastℕ]+ range = [0, 1 .. (samples-1)]+ (xrange, yrange) = ( fmap ((\s -> x1+s*dx/fromFastℕtoℝ (samples-1)) . fromFastℕtoℝ) range, fmap ((\s -> y1+s*dy/fromFastℕtoℝ (samples-1)) . fromFastℕtoℝ) range)++ hfuzz :: ℝ+ hfuzz = 0.2+ h = case height of+ Left hval -> hval+ Right hfun -> hmax + hfuzz*(hmax-hmin) where- hs = [hf (x,y) | x <- xrange, y <- yrange]+ hs = [hfun (x,y) | x <- xrange, y <- yrange] (hmin, hmax) = (minimum hs, maximum hs)- hrange = map (h*) range- sval = case scale of- Nothing -> 1- Just scale' -> maximum $ map (abs . scale') hrange- (twistXmin, twistYmin, twistXmax, twistYmax) = case twist of- Nothing -> (smin x1, smin y1, smax x2, smax y2)- where- smin y = min y (sval * y)- smax y = max y (sval * y)- Just _ -> (-d, -d, d, d)- where d = sval * getDist2 (0,0) symbObj- translate' = fromMaybe (const (0,0)) translate- (tvalsx, tvalsy) = unzip . map (translate' . (h*)) $ hrange- (tminx, tminy) = (minimum tvalsx, minimum tvalsy)- (tmaxx, tmaxy) = (maximum tvalsx, maximum tvalsy)+ hrange = fmap ((/ fromFastℕtoℝ (samples-1)) . (h*) . fromFastℕtoℝ) range++ (twistXmin, twistYmin, twistXmax, twistYmax) =+ let+ scale' = case scale of+ Left sval -> sval+ Right sfun -> maximum $ fmap (abs . sfun) hrange+ smin v = min v (scale' * v)+ smax v = max v (scale' * v)+ -- FIXME: assumes minimums are negative, and maximums are positive.+ scaleVal d = scale' * d+ scaleEach ((d1, d2),(d3, d4)) = (scaleVal d1, scaleVal d2, scaleVal d3, scaleVal d4) + in case twist of+ Left twval -> if twval == 0+ then (smin x1, smin y1, smax x2, smax y2)+ else scaleEach $ getBox2R symbObj twval+ Right _ -> scaleEach $ getBox2R symbObj 360 -- we can't range functions yet, so assume a full circle.++ (tminx, tmaxx, tminy, tmaxy) =+ let+ tvalsx :: (ℝ -> (ℝ, ℝ)) -> [ℝ]+ tvalsx tfun = fmap (fst . tfun) hrange+ tvalsy :: (ℝ -> (ℝ, ℝ)) -> [ℝ]+ tvalsy tfun = fmap (snd . tfun) hrange+ in case translate of+ Left (tvalx, tvaly) -> (tvalx, tvalx, tvaly, tvaly)+ Right tfun -> (minimum $ tvalsx tfun, maximum $ tvalsx tfun, minimum $ tvalsy tfun, maximum $ tvalsy tfun) in ((twistXmin + tminx, twistYmin + tminy, 0),(twistXmax + tmaxx, twistYmax + tmaxy, h)) -- Note: Assumes x2 is always greater than x1.--- FIXME: Insert the above assumption as an assertion in the language structure?+-- FIXME: Insert the above assumption as an assertion in the type system? getBox3 (RotateExtrude _ _ (Left (xshift,yshift)) _ symbObj) = let ((_,y1),(x2,y2)) = getBox2 symbObj r = max x2 (x2 + xshift) in ((-r, -r, min y1 (y1 + yshift)),(r, r, max y2 (y2 + yshift)))--- FIXME: magic numbers+-- FIXME: magic numbers: 0.1, 1.1, and 11.+-- FIXME: this may use an approximation, based on sampling functions. generate a warning if the approximation part of this function is used.+-- FIXME: re-implement the expression system, so this can recieve a function, and determine class (constant, linear)... and implement better forms of this function. getBox3 (RotateExtrude rot _ (Right f) rotate symbObj) = let+ samples :: Fastℕ+ samples = 11+ xfuzz :: ℝ+ xfuzz = 1.1+ yfuzz :: ℝ+ yfuzz=0.1+ range :: [Fastℕ]+ range = [0, 1 .. (samples-1)]+ step = rot/fromFastℕtoℝ (samples-1) ((x1,y1),(x2,y2)) = getBox2 symbObj- (xshifts, yshifts) = unzip [f θ | θ <- [0 , rot / 10 .. rot] ]- xmax = maximum xshifts- ymax = maximum yshifts- ymin = minimum yshifts- xmax' | xmax > 0 = xmax * 1.1+ (xrange, yrange) = unzip $ take (fromFastℕ samples) $ fmap (f . (step*) . fromFastℕtoℝ) range+ xmax = maximum xrange+ ymax = maximum yrange+ ymin = minimum yrange+ xmax' | xmax > 0 = xmax * xfuzz | xmax < - x1 = 0 | otherwise = xmax- ymax' = ymax + 0.1 * (ymax - ymin)- ymin' = ymin - 0.1 * (ymax - ymin)+ ymax' = ymax + yfuzz * (ymax - ymin)+ ymin' = ymin - yfuzz * (ymax - ymin) (r, _, _) = if either (==0) (const False) rotate then let- s = maximum $ map abs [x2, y1, y2]+ s = maximum $ fmap abs [x2, y1, y2] in (s + xmax', s + ymin', y2 + ymax') else (x2 + xmax', y1 + ymin', y2 + ymax') in
Graphics/Implicit/ObjectUtil/GetImplicit2.hs view
@@ -2,22 +2,16 @@ -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}---- FIXME: required. why?-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}- module Graphics.Implicit.ObjectUtil.GetImplicit2 (getImplicit2) where -import Prelude(Num, abs, (-), (/), sqrt, (*), (+), (!!), mod, length, map, (<=), (&&), (>=), (||), odd, ($), (>), filter, (<), minimum, (==), maximum, max, cos, sin, head, tail, (.))+import Prelude(abs, (-), (/), sqrt, (*), (+), mod, length, fmap, (<=), (&&), (>=), (||), odd, ($), (>), filter, (<), minimum, max, cos, sin, head, tail, (.)) -import Graphics.Implicit.Definitions (ℝ, Fastℕ, ℝ2, (⋯/), Obj2, SymbolicObj2(RectR, Circle, PolygonR, Complement2, UnionR2, DifferenceR2, IntersectR2, Translate2, Scale2, Rotate2, Shell2, Outset2, EmbedBoxedObj2))+import Graphics.Implicit.Definitions (ℝ, ℕ, ℝ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 ((^-^))-import Data.List (nub)+import Data.List (nub, genericIndex, genericLength) getImplicit2 :: SymbolicObj2 -> Obj2 -- Primitives@@ -25,17 +19,17 @@ \(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]+ 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+-- FIXME: stop ignoring rounding for polygons. getImplicit2 (PolygonR _ points) = \p -> let- 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+ pair :: ℕ -> (ℝ2,ℝ2)+ pair n = (points `genericIndex` n, points `genericIndex` mod (n + 1) (genericLength points) )+ pairs :: [(ℝ2,ℝ2)]+ pairs = [ pair n | n <- [0 .. genericLength points - 1] ]+ relativePairs = fmap (\(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) ) ]@@ -43,7 +37,8 @@ seemsInRight = odd . length . filter (>0) $ nub crossing_points seemsInLeft = odd . length . filter (<0) $ nub crossing_points isIn = seemsInRight && seemsInLeft- dists = map (distFromLineSeg p) pairs :: [ℝ]+ dists :: [ℝ]+ dists = fmap (distFromLineSeg p) pairs in minimum dists * if isIn then -1 else 1 -- (Rounded) CSG@@ -54,28 +49,22 @@ - obj p getImplicit2 (UnionR2 r symbObjs) = \p -> let- objs = map getImplicit2 symbObjs+ objs = fmap getImplicit2 symbObjs in- if r == 0- then minimum $ map ($p) objs- else rminimum r $ map ($p) objs+ rminimum r $ fmap ($p) objs getImplicit2 (DifferenceR2 r symbObjs) = let- objs = map getImplicit2 symbObjs+ objs = fmap getImplicit2 symbObjs obj = head objs- complement :: forall a t. Num a => (t -> a) -> t -> a+ complement :: Obj2 -> ℝ2 -> ℝ 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)+ \p -> rmaximum r . fmap ($p) $ obj:fmap complement (tail objs) getImplicit2 (IntersectR2 r symbObjs) = \p -> let- objs = map getImplicit2 symbObjs+ objs = fmap getImplicit2 symbObjs in- if r == 0- then maximum $ map ($p) objs- else rmaximum r $ map ($p) objs+ rmaximum r $ fmap ($p) objs -- Simple transforms getImplicit2 (Translate2 v symbObj) = \p -> let@@ -85,7 +74,7 @@ getImplicit2 (Scale2 s@(sx,sy) symbObj) = \p -> let obj = getImplicit2 symbObj- k = abs(max sx sy)+ k = abs $ max sx sy in k * obj (p ⋯/ s) getImplicit2 (Rotate2 θ symbObj) =
Graphics/Implicit/ObjectUtil/GetImplicit3.hs view
@@ -3,39 +3,45 @@ -- 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 #-}- module Graphics.Implicit.ObjectUtil.GetImplicit3 (getImplicit3) where -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 Prelude (Either(Left, Right), abs, (-), (/), (*), sqrt, (+), atan2, max, cos, fmap, minimum, ($), (**), sin, pi, (.), Bool(True, False), ceiling, floor, pure, error, head, tail, (>), (&&), (<), (==), otherwise, (<$>)) -import Graphics.Implicit.Definitions (ℝ, Fastℕ, ℝ2, ℝ3, (⋯/), Obj3,+import Graphics.Implicit.Definitions (ℝ, ℕ, ℝ2, ℝ3, (⋯/), Obj3, SymbolicObj3(Shell3, UnionR3, IntersectR3, DifferenceR3, Translate3, Scale3, Rotate3, Outset3, Rect3R, Sphere, Cylinder, Complement3, EmbedBoxedObj3, Rotate3V,- ExtrudeR, ExtrudeRM, ExtrudeOnEdgeOf, RotateExtrude, ExtrudeRotateR))+ ExtrudeR, ExtrudeRM, ExtrudeOnEdgeOf, RotateExtrude, ExtrudeRotateR), fromℕtoℝ, (⋅), minℝ)+ import Graphics.Implicit.MathUtil (rmaximum, rminimum, rmax)-import qualified Data.Maybe as Maybe-import qualified Data.Either as Either-import Data.VectorSpace ((^-^), (^+^), (^*), (<.>), normalized) +import Data.Maybe (fromMaybe, isJust)++import qualified Data.Either as Either (either)++import Data.VectorSpace ((^*), normalized)++import Data.Cross(cross3)+ -- Use getImplicit2 for handling extrusion of 2D shapes to 3D. import Graphics.Implicit.ObjectUtil.GetImplicit2 (getImplicit2) +default (ℝ)++-- Get a function that describes the surface of the object. getImplicit3 :: SymbolicObj3 -> Obj3 -- Primitives 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 ) =+getImplicit3 (Sphere r) = \(x,y,z) -> sqrt (x*x + y*y + z*z) - r getImplicit3 (Cylinder h r1 r2) = \(x,y,z) -> let- d = sqrt(x*x + y*y) - ((r2-r1)/h*z+r1)+ d = sqrt (x*x + y*y) - ((r2-r1)/h*z+r1) θ = atan2 (r2-r1) h in- max (d * cos θ) (abs(z-h/(2::ℝ)) - h/(2::ℝ))+ max (d * cos θ) (abs (z-h/2) - (h/2)) -- (Rounded) CSG getImplicit3 (Complement3 symbObj) = let@@ -43,39 +49,35 @@ in \p -> - obj p getImplicit3 (UnionR3 r symbObjs) =- let- objs = map getImplicit3 symbObjs- in- if r == 0- then \p -> minimum $ map ($p) objs- else \p -> rminimum r $ map ($p) objs+ \p -> rminimum r $ fmap ($p) $ getImplicit3 <$> symbObjs+ getImplicit3 (IntersectR3 r symbObjs) =- let- objs = map getImplicit3 symbObjs- in- if r == 0- then \p -> maximum $ map ($p) objs- else \p -> rmaximum r $ map ($p) objs+ \p -> rmaximum r $ fmap ($p) $ getImplicit3 <$> symbObjs+ getImplicit3 (DifferenceR3 r symbObjs) = let- objs = map getImplicit3 symbObjs- obj = head objs- complement :: forall a t. Num a => (t -> a) -> t -> a+ tailObjs = getImplicit3 <$> tail symbObjs+ headObj = getImplicit3 $ head symbObjs+ complement :: Obj3 -> ℝ3 -> ℝ 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)+ \p -> do+ let+ maxTail = rmaximum r $ fmap ($p) $ complement <$> tailObjs+ if maxTail > -minℝ && maxTail < minℝ+ then rmax r (headObj p) minℝ+ else rmax r (headObj p) maxTail+ -- Simple transforms getImplicit3 (Translate3 v symbObj) = let obj = getImplicit3 symbObj in- \p -> obj (p ^-^ v)+ \p -> obj (p - v) getImplicit3 (Scale3 s@(sx,sy,sz) symbObj) = let obj = getImplicit3 symbObj- k = abs(sx*sy*sz)**(1/3)+ k = abs (sx*sy*sz) ** (1/3) in \p -> k * obj (p ⋯/ s) getImplicit3 (Rotate3 (yz, zx, xy) symbObj) =@@ -88,21 +90,16 @@ rotateXY :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ) rotateXY θ obj' (x,y,z) = obj' ( x*cos θ + y*sin θ, y*cos θ - x*sin θ, z) in- rotateYZ yz . rotateZX zx $ rotateXY xy obj+ rotateXY xy $ rotateZX zx $ rotateYZ yz obj getImplicit3 (Rotate3V θ axis symbObj) = let axis' = normalized axis obj = getImplicit3 symbObj- -- Note: this is ripped from data.cross.- cross3 :: forall t. Num t => (t, t, t) -> (t, t, t) -> (t, t, t)- cross3 (ax,ay,az) (bx,by,bz) = ( ay * bz - az * by- , az * bx - ax * bz- , ax * by - ay * bx ) in \v -> obj $ v ^* cos θ- ^-^ (axis' `cross3` v) ^* sin θ- ^+^ (axis' ^* (axis' <.> (v ^* (1 - cos θ))))+ - (axis' `cross3` v) ^* sin θ+ + (axis' ^* (axis' ⋅ (v ^* (1 - cos θ)))) -- Boundary mods getImplicit3 (Shell3 w symbObj) = let@@ -125,22 +122,49 @@ getImplicit3 (ExtrudeRM r twist scale translate symbObj height) = let obj = getImplicit2 symbObj- twist' = Maybe.fromMaybe (const 0) twist- scale' = Maybe.fromMaybe (const 1) scale- translate' = Maybe.fromMaybe (const (0,0)) translate height' (x,y) = case height of Left n -> n Right f -> f (x,y)- scaleVec :: ℝ -> ℝ2 -> ℝ2- scaleVec s (x,y) = (x/s, y/s)+ -- FIXME: twist functions should have access to height, if height is allowed to vary.+ twistVal :: Either ℝ (ℝ -> ℝ) -> ℝ -> ℝ -> ℝ+ twistVal twist' z h =+ case twist' of+ Left twval -> if twval == 0+ then 0+ else twval * (z / h)+ Right twfun -> twfun z+ translatePos :: Either ℝ2 (ℝ -> ℝ2) -> ℝ -> ℝ2 -> ℝ2+ translatePos trans z (x, y) = (x - xTrans, y - yTrans)+ where+ (xTrans, yTrans) = case trans of+ Left tval -> tval+ Right tfun -> tfun z+ scaleVec :: Either ℝ (ℝ -> ℝ) -> ℝ -> ℝ2 -> ℝ2+ scaleVec scale' s (x,y) =+ case scale' of+ Left sval -> if sval == 1+ then (x,y)+ else (x/sval , y/sval)+ Right sfun -> (x/sfun s, y/sfun s) rotateVec :: ℝ -> ℝ2 -> ℝ2- rotateVec θ (x,y) = (x*cos θ + y*sin θ, y*cos θ - x*sin θ)- k = (pi :: ℝ)/(180:: ℝ)+ rotateVec θ (x,y)+ | θ == 0 = (x,y)+ | otherwise = (x*cos θ + y*sin θ, y*cos θ - x*sin θ)+ k :: ℝ+ k = pi/180 in- \(x,y,z) -> let h = height' (x,y) in- rmax r- (obj . rotateVec (-k*twist' z) . scaleVec (scale' z) . (\a -> a ^-^ translate' z) $ (x,y))+ \(x,y,z) ->+ let+ h = height' (x,y)+ res = rmax r+ (obj+ . rotateVec (-k*twistVal twist z h)+ . scaleVec scale z+ . translatePos translate z+ $ (x,y)) (abs (z - h/2) - h/2)+ in+ res getImplicit3 (ExtrudeOnEdgeOf symbObj1 symbObj2) = let obj1 = getImplicit2 symbObj1@@ -155,8 +179,8 @@ k = tau / 360 totalRotation' = totalRotation*k obj = getImplicit2 symbObj- capped = Maybe.isJust round- round' = Maybe.fromMaybe 0 round+ capped = isJust round+ round' = fromMaybe 0 round translate' :: ℝ -> ℝ2 translate' = Either.either (\(a,b) θ -> (a*θ/totalRotation', b*θ/totalRotation'))@@ -172,35 +196,35 @@ _ -> False in \(x,y,z) -> minimum $ do- let- r = sqrt (x*x + y*y)+ r = sqrt $ x*x + y*y θ = atan2 y x- ns :: [Fastℕ]+ ns :: [ℕ] 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] n <- ns let- θvirt = fromIntegral n * tau + θ+ θvirt = fromℕtoℝ n * tau + θ (rshift, zshift) = translate' θvirt twist = rotate' θvirt rz_pos = if twists then let- (c,s) = (cos(twist*k), sin(twist*k))+ (c,s) = (cos (twist*k), sin (twist*k)) (r',z') = (r-rshift, z-zshift) in (c*r' - s*z', c*z' + s*r') else (r - rshift, z - zshift)- return $- if capped- then rmax round'+ pure $+ if capped+ then rmax round' (abs (θvirt - (totalRotation' / 2)) - (totalRotation' / 2)) (obj rz_pos)- else obj rz_pos+ else obj rz_pos+ -- FIXME: implement this, or implement a fallthrough function. --getImplicit3 (ExtrudeRotateR) = getImplicit3 ExtrudeRotateR{} = error "ExtrudeRotateR unimplimented!"
Graphics/Implicit/Primitives.hs view
@@ -2,11 +2,9 @@ -- Copyright (C) 2014 2015 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}- -- FIXME: Required. why?-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-} -- A module exporting all of the primitives, and some operations on them. module Graphics.Implicit.Primitives (@@ -38,7 +36,7 @@ implicit ) where -import Prelude(Maybe(Just, Nothing), Either, map, ($))+import Prelude(Maybe(Just, Nothing), Either, fmap, ($)) import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, Box2, SymbolicObj2(@@ -138,12 +136,12 @@ -- $ Shared Operations class Object obj vec | obj -> vec where- + -- | Complement an Object complement :: obj -- ^ Object to complement -> obj -- ^ Result- + -- | Rounded union unionR :: ℝ -- ^ The radius of rounding@@ -161,7 +159,7 @@ ℝ -- ^ The radius of rounding -> [obj] -- ^ Objects to intersect -> obj -- ^ Resulting object- + -- | Translate an object by a vector of appropriate dimension. translate :: vec -- ^ Vector to translate by (Also: a is a vector, blah, blah)@@ -200,8 +198,8 @@ (vec -> ℝ) -- ^ Implicit function -> (vec, vec) -- ^ Bounding box -> obj -- ^ Resulting object- + instance Object SymbolicObj2 ℝ2 where translate = Translate2 scale = Scale2@@ -228,13 +226,13 @@ getImplicit = getImplicit3 implicit a b= EmbedBoxedObj3 (a,b) -union :: forall obj vec. Object obj vec => [obj] -> obj+union :: Object obj vec => [obj] -> obj union = unionR 0 -difference :: forall obj vec. Object obj vec => [obj] -> obj+difference :: Object obj vec => [obj] -> obj difference = differenceR 0 -intersect :: forall obj vec. Object obj vec => [obj] -> obj+intersect :: Object obj vec => [obj] -> obj intersect = intersectR 0 -- 3D operations@@ -246,9 +244,9 @@ extrudeRotateR = ExtrudeRotateR extrudeRM :: ℝ- -> Maybe (ℝ -> ℝ)- -> Maybe (ℝ -> ℝ)- -> Maybe (ℝ -> ℝ2)+ -> Either ℝ (ℝ -> ℝ)+ -> Either ℝ (ℝ -> ℝ)+ -> Either ℝ2 (ℝ -> ℝ2) -> SymbolicObj2 -> Either ℝ (ℝ2 -> ℝ) -> SymbolicObj3@@ -265,7 +263,7 @@ extrudeOnEdgeOf :: SymbolicObj2 -> SymbolicObj2 -> SymbolicObj3 extrudeOnEdgeOf = ExtrudeOnEdgeOf -rotate3 :: (ℝ, ℝ, ℝ) -> SymbolicObj3 -> SymbolicObj3+rotate3 :: ℝ3 -> SymbolicObj3 -> SymbolicObj3 rotate3 = Rotate3 rotate3V :: ℝ -> ℝ3 -> SymbolicObj3 -> SymbolicObj3@@ -275,12 +273,12 @@ pack3 :: ℝ2 -> ℝ -> [SymbolicObj3] -> Maybe SymbolicObj3 pack3 (dx, dy) sep objs = let- boxDropZ :: forall t t1 t2 t3 t4 t5. ((t2, t3, t), (t4, t5, t1)) -> ((t2, t3), (t4, t5))+ boxDropZ :: (ℝ3,ℝ3) -> (ℝ2,ℝ2) boxDropZ ((a,b,_),(d,e,_)) = ((a,b),(d,e)) withBoxes :: [(Box2, SymbolicObj3)]- withBoxes = map (\obj -> ( boxDropZ $ getBox3 obj, obj)) objs+ withBoxes = fmap (\obj -> ( boxDropZ $ getBox3 obj, obj)) objs in case pack ((0,0),(dx,dy)) sep withBoxes of- (a, []) -> Just $ union $ map (\((x,y),obj) -> translate (x,y,0) obj) a+ (a, []) -> Just $ union $ fmap (\((x,y),obj) -> translate (x,y,0) obj) a _ -> Nothing -- 2D operations@@ -292,8 +290,8 @@ pack2 (dx, dy) sep objs = let withBoxes :: [(Box2, SymbolicObj2)]- withBoxes = map (\obj -> ( getBox2 obj, obj)) objs+ withBoxes = fmap (\obj -> ( getBox2 obj, obj)) objs in case pack ((0,0),(dx,dy)) sep withBoxes of- (a, []) -> Just $ union $ map (\((x,y),obj) -> translate (x,y) obj) a+ (a, []) -> Just $ union $ fmap (\((x,y),obj) -> translate (x,y) obj) a _ -> Nothing
− Makefile
@@ -1,78 +0,0 @@-.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
@@ -1,312 +0,0 @@-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?
− docgen.hs
@@ -1,88 +0,0 @@--- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)--- Released under the GNU GPL, see LICENSE--{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ScopedTypeVariables #-}---- 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
@@ -1,174 +0,0 @@--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,258 +1,301 @@-name: implicit-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.- Build objects with constructive solid geometry, bevels,- shells and more in 2D & 3D. Then export to SVGs, STLs,- or produce gcode directly!-license: AGPL-3-license-file: LICENSE-author: Christopher Olah-maintainer: Julia Longtin <julial@turinglace.com>-homepage: http://kalli1.faikvm.com/ImplicitCAD/Stable-build-type: Simple-category: Graphics--library-- build-depends:- base >= 3 && < 5,- filepath,- directory,- parsec,- unordered-containers,- parallel,- containers,- deepseq,- vector-space,- text,- monads-tf,- bytestring,- bytestring-builder,- blaze-builder,- blaze-markup,- blaze-svg,- storable-endian,- JuicyPixels,- NumInstances,- criterion,- snap-core,- snap-server,- silently,- transformers,- hspec+Name: implicit+Version: 0.3.0.0+Cabal-version: >= 1.10+Tested-with: GHC >= 8.6+Build-type: Simple+Synopsis: A math-inspired programmatic 2&3D CAD system.+Description: An OpenSCAD execution engine for generating models in STL and many other formats.+License: AGPL-3+License-file: LICENSE+Author: Julia Longtin <julia.longtin@gmail.com>+Maintainer: Julia Longtin <julia.longtin@gmail.com>+Homepage: http://implicitcad.org/+Category: Graphics - ghc-options:- -Wall--- for debugging only.- -Wextra- -Weverything- -O2- -optc-O3--- cannot use, we use infinity in some calculations.--- -optc-ffast-math+Library - extensions:- exposed-modules:- Graphics.Implicit- Graphics.Implicit.Definitions- Graphics.Implicit.Primitives- Graphics.Implicit.Export- Graphics.Implicit.MathUtil- Graphics.Implicit.ExtOpenScad- Graphics.Implicit.ObjectUtil- -- Note that these modules are only temporarily exposed, to- -- allow coding the unit tests against the current parser- -- interface.- Graphics.Implicit.ExtOpenScad.Parser.Statement- Graphics.Implicit.ExtOpenScad.Parser.Expr- Graphics.Implicit.ExtOpenScad.Definitions- -- these are exported for Benchmark.- Graphics.Implicit.Export.SymbolicObj2- Graphics.Implicit.Export.SymbolicObj3- -- these are exported for implicitsnap.- Graphics.Implicit.Export.TriangleMeshFormats- Graphics.Implicit.Export.PolylineFormats- Graphics.Implicit.Export.DiscreteAproxable+ Default-Extensions: NoImplicitPrelude+ Default-Language: Haskell2010+ Build-depends:+ base >= 3 && < 5,+ filepath,+ directory,+ parsec,+ parallel,+ containers,+ deepseq,+ vector-space,+ hspec,+ text,+ monads-tf,+ bytestring,+ blaze-builder,+ blaze-markup,+ blaze-svg,+ storable-endian,+ JuicyPixels,+ transformers - other-modules:- Graphics.Implicit.ObjectUtil.GetBox2- Graphics.Implicit.ObjectUtil.GetBox3- Graphics.Implicit.ObjectUtil.GetImplicit2- Graphics.Implicit.ObjectUtil.GetImplicit3- Graphics.Implicit.ExtOpenScad.Default- Graphics.Implicit.ExtOpenScad.Parser.Util- Graphics.Implicit.ExtOpenScad.Primitives- Graphics.Implicit.ExtOpenScad.Eval.Statement- Graphics.Implicit.ExtOpenScad.Eval.Expr- Graphics.Implicit.ExtOpenScad.Util.StateC- Graphics.Implicit.ExtOpenScad.Util.ArgParser- Graphics.Implicit.ExtOpenScad.Util.OVal- Graphics.Implicit.Export.MarchingSquares- Graphics.Implicit.Export.MarchingSquaresFill- Graphics.Implicit.Export.RayTrace- Graphics.Implicit.Export.NormedTriangleMeshFormats- Graphics.Implicit.Export.SymbolicFormats- Graphics.Implicit.Export.Util- Graphics.Implicit.Export.TextBuilderUtils- Graphics.Implicit.Export.Symbolic.Rebound2- Graphics.Implicit.Export.Symbolic.Rebound3- Graphics.Implicit.Export.Render- Graphics.Implicit.Export.Render.Definitions- Graphics.Implicit.Export.Render.GetLoops- Graphics.Implicit.Export.Render.GetSegs- Graphics.Implicit.Export.Render.HandleSquares- Graphics.Implicit.Export.Render.Interpolate- Graphics.Implicit.Export.Render.RefineSegs- Graphics.Implicit.Export.Render.TesselateLoops- Graphics.Implicit.Export.Render.HandlePolylines+ Ghc-options:+-- -O2+ -optc-O3+-- -dynamic+ -- see GHC manual 8.2.1 section 6.5.1.+ -feager-blackholing+ -- for debugging.+ -Wall+ -Wcompat+ -Wmonomorphism-restriction+ -Wmissing-local-signatures+ -Wmissing-export-lists+ -Wmissing-import-lists+ -Wmissing-home-modules+ -Widentities+ -Wimplicit-prelude+ -Wredundant-constraints+ -Wall-missed-specialisations+-- -Werror+ Exposed-modules:+ Graphics.Implicit+ Graphics.Implicit.Definitions+ Graphics.Implicit.Primitives+ Graphics.Implicit.Export+ Graphics.Implicit.MathUtil+ Graphics.Implicit.ExtOpenScad+ Graphics.Implicit.ObjectUtil+ -- These modules are exposed for the unit tests against the parser interface.+ Graphics.Implicit.ExtOpenScad.Parser.Statement+ Graphics.Implicit.ExtOpenScad.Parser.Expr+ Graphics.Implicit.ExtOpenScad.Eval.Constant+ Graphics.Implicit.ExtOpenScad.Definitions+ -- These are exposed for Benchmark.+ Graphics.Implicit.Export.SymbolicObj2+ Graphics.Implicit.Export.SymbolicObj3+ -- These are exposed for implicitsnap.+ Graphics.Implicit.Export.TriangleMeshFormats+ Graphics.Implicit.Export.NormedTriangleMeshFormats+ Graphics.Implicit.Export.PolylineFormats+ Graphics.Implicit.Export.DiscreteAproxable+ -- These are exposed for docgen.+ Graphics.Implicit.ExtOpenScad.Primitives -executable extopenscad+ Other-modules:+ Graphics.Implicit.FastIntUtil+ Graphics.Implicit.IntegralUtil+ Graphics.Implicit.ObjectUtil.GetBox2+ Graphics.Implicit.ObjectUtil.GetBox3+ Graphics.Implicit.ObjectUtil.GetImplicit2+ Graphics.Implicit.ObjectUtil.GetImplicit3+ Graphics.Implicit.ExtOpenScad.Default+ Graphics.Implicit.ExtOpenScad.Parser.Lexer+ Graphics.Implicit.ExtOpenScad.Parser.Util+ Graphics.Implicit.ExtOpenScad.Eval.Statement+ Graphics.Implicit.ExtOpenScad.Eval.Expr+ Graphics.Implicit.ExtOpenScad.Util.ArgParser+ Graphics.Implicit.ExtOpenScad.Util.OVal+ Graphics.Implicit.ExtOpenScad.Util.StateC+ Graphics.Implicit.Export.MarchingSquaresFill+ Graphics.Implicit.Export.RayTrace+ Graphics.Implicit.Export.SymbolicFormats+ Graphics.Implicit.Export.Util+ Graphics.Implicit.Export.TextBuilderUtils+ Graphics.Implicit.Export.Symbolic.Rebound2+ Graphics.Implicit.Export.Symbolic.Rebound3+ Graphics.Implicit.Export.Render+ Graphics.Implicit.Export.Render.Definitions+ Graphics.Implicit.Export.Render.GetLoops+ Graphics.Implicit.Export.Render.GetSegs+ Graphics.Implicit.Export.Render.HandleSquares+ Graphics.Implicit.Export.Render.Interpolate+ Graphics.Implicit.Export.Render.RefineSegs+ Graphics.Implicit.Export.Render.TesselateLoops+ Graphics.Implicit.Export.Render.HandlePolylines - main-is: extopenscad.hs- hs-source-dirs: programs- build-depends:+Executable extopenscad+ Main-is: extopenscad.hs+ default-extensions: NoImplicitPrelude+ Default-Language: Haskell2010+ Hs-source-dirs: programs+ Build-depends: base,- containers, vector-space, filepath,- parallel, optparse-applicative >= 0.10.0, 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---- FIXME: does not compile.---Executable docgen+ Ghc-options:+-- -O2+ -optc-O3+ -threaded+ -rtsopts+-- -dynamic+ -- see GHC manual 8.2.1 section 6.5.1.+ -feager-blackholing+ -- for debugging.+ -Wall+ -Wcompat+ -Wmonomorphism-restriction+ -Wmissing-local-signatures+ -Wmissing-export-lists+ -Wmissing-import-lists+ -Wmissing-home-modules+ -Widentities+ -Wimplicit-prelude+ -Wredundant-constraints+ -Wall-missed-specialisations+-- -Werror --- main-is: docgen.hs--- build-depends:--- base,--- vector-space,--- text,--- JuicyPixels,--- blaze-builder,--- blaze-svg,--- blaze-markup,--- parallel,--- deepseq,--- vector-space,--- monads-tf,--- bytestring,--- storable-endian,--- parsec,--- directory,--- containers,--- filepath,--- snap-core,--- snap-server,--- silently,--- transformers--- ghc-options:--- -optc-O3--- -threaded--- -rtsopts--- -funfolding-use-threshold=16--- -fspec-constr-count=10- -executable implicitsnap- main-is: implicitsnap.hs- hs-source-dirs: programs+Executable docgen+ main-is: docgen.hs+ default-extensions: NoImplicitPrelude+ Default-Language: Haskell2010+ Hs-source-dirs: programs build-depends: base,- vector-space,- text,- JuicyPixels,- blaze-builder,- blaze-svg,- blaze-markup,- parallel,- deepseq,- vector-space,- monads-tf,- bytestring,- storable-endian,- parsec,- directory,- containers,- filepath,- snap-core,- snap-server,- silently,- transformers, implicit ghc-options:- -threaded- -rtsopts- -Wall- -Weverything- -O2- -optc-O3- -optc-ffast-math+-- -dynamic+ -- for debugging.+ -Wall+ -Wcompat+ -Wmonomorphism-restriction+ -Wmissing-local-signatures+ -Wmissing-export-lists+ -Wmissing-import-lists+ -Wmissing-home-modules+ -Widentities+ -Wimplicit-prelude+ -Wredundant-constraints+ -Wall-missed-specialisations+-- -Werror -executable Benchmark- main-is: Benchmark.hs- hs-source-dirs: programs- build-depends:+Executable implicitsnap+ Main-is: implicitsnap.hs+ default-extensions: NoImplicitPrelude+ Default-Language: Haskell2010+ Hs-source-dirs: programs+ Build-depends: base,- text,- JuicyPixels,- blaze-svg,- blaze-markup,- parallel,- deepseq,- vector-space,- monads-tf,- blaze-builder, bytestring,- storable-endian,- parsec,- directory,- containers,- filepath,+ implicit,+ snap-core,+ snap-server,+ text,+ vector-space+ Ghc-options:+ -threaded+ -rtsopts+-- -O2+ -optc-O3+-- -dynamic+ -- see GHC manual 8.2.1 section 6.5.1.+ -feager-blackholing+ -- for debugging.+ -Wall+ -Wcompat+ -Wmonomorphism-restriction+ -Wmissing-local-signatures+ -Wmissing-export-lists+ -Wmissing-import-lists+ -Wmissing-home-modules+ -Widentities+ -Wimplicit-prelude+ -Wredundant-constraints+ -Wall-missed-specialisations+-- -Werror++Executable Benchmark+ Main-is: Benchmark.hs+ default-extensions: NoImplicitPrelude+ Default-Language: Haskell2010+ Hs-source-dirs: programs+ Build-depends:+ base, criterion,- transformers, implicit- ghc-options:- -threaded- -rtsopts- -Wall- -Weverything- -O2- -optc-O3- -optc-ffast-math+ Ghc-options:+-- -O2+ -optc-O3+-- -dynamic+ -- for debugging.+ -Wall+ -Wcompat+ -Wmonomorphism-restriction+ -Wmissing-local-signatures+ -Wmissing-export-lists+ -Wmissing-import-lists+ -Wmissing-home-modules+ -Widentities+ -Wimplicit-prelude+ -Wredundant-constraints+ -Wall-missed-specialisations+-- -Werror -test-suite test-implicit- type: exitcode-stdio-1.0- build-depends: base, mtl, containers, hspec, parsec, implicit- main-is: Main.hs- hs-source-dirs: tests- ghc-options:- -Wall- -Weverything- -O2- -optc-O3+Test-suite test-implicit+ Type: exitcode-stdio-1.0+ default-extensions: NoImplicitPrelude+ Default-Language: Haskell2010+ Build-depends:+ base,+ hspec,+ implicit,+ parsec+ Main-is: Main.hs+ Hs-source-dirs: tests+ Ghc-options:+-- -O2+ -optc-O3+-- -dynamic+ -- for debugging.+ -Wall+ -Wcompat+ -Wmonomorphism-restriction+ -Wmissing-local-signatures+ -Wmissing-export-lists+ -Wmissing-import-lists+ -Wmissing-home-modules+ -Widentities+ -Wimplicit-prelude+ -Wredundant-constraints+ -Wall-missed-specialisations+-- -Werror+ Other-Modules:+ ParserSpec.Expr+ ParserSpec.Statement+ ParserSpec.Util+ ExecSpec.Expr+ ExecSpec.Util+ MessageSpec.Message+ MessageSpec.Util -benchmark parser-bench- type: exitcode-stdio-1.0- build-depends: base, criterion, random, parsec, implicit- main-is: ParserBench.hs- ghc-options:- -Wall- -Weverything- -O2- -optc-O3- -optc-ffast-math+Benchmark parser-bench+ Type: exitcode-stdio-1.0+ default-extensions: NoImplicitPrelude+ Default-Language: Haskell2010+ Build-depends:+ base,+ criterion,+ parsec,+ implicit+ Main-is: parser-bench.hs+ Hs-source-dirs: programs+ Ghc-options:+-- -O2+ -optc-O3+-- -dynamic+ -- for debugging.+ -Wall+ -Wcompat+ -Wmonomorphism-restriction+ -Wmissing-local-signatures+ -Wmissing-export-lists+ -Wmissing-import-lists+ -Wmissing-home-modules+ -Widentities+ -Wimplicit-prelude+ -Wredundant-constraints+ -Wall-missed-specialisations+-- -Werror -source-repository head- type: git- location: https://github.com/colah/ImplicitCAD.git+Source-repository head+ Type: git+ Location: https://github.com/colah/ImplicitCAD.git
programs/Benchmark.hs view
@@ -2,31 +2,31 @@ -- Copyright (C) 2014 2015 2016, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Benchmarks+-- Our benchmarking suite. -- Let's be explicit about where things come from :) -import Prelude (($), (*), (/), String, IO, cos, pi, map, zip3, Maybe(Just, Nothing), Either(Left))+import Prelude (($), (*), (/), String, IO, cos, pi, fmap, zip3, Either(Left, Right), fromIntegral, (<>), (<$>)) -- Use criterion for benchmarking. see <http://www.serpentine.com/criterion/>-import Criterion.Main (Benchmark, bgroup, bench, nf, defaultMain)+import Criterion.Main (Benchmark, bgroup, bench, nf, nfAppIO, defaultMain) --- The parts of ImplicitCAD we know how to benchmark (in theory).-import Graphics.Implicit (union, circle, SymbolicObj2, SymbolicObj3)+-- The parts of ImplicitCAD we know how to benchmark.+import Graphics.Implicit (union, circle, sphere, SymbolicObj2, SymbolicObj3, writeDXF2, writeSVG, writePNG2, writeSTL, writeBinSTL, unionR, translate, difference, extrudeRM, rect3R) 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 (ℝ)+-- The variables defining distance and counting in our world.+import Graphics.Implicit.Definitions (ℝ, Fastℕ) -- Haskell representations of objects to benchmark. -- FIXME: move each of these objects into seperate compilable files. +-- | What we extrude in the example on the website. obj2d_1 :: SymbolicObj2 obj2d_1 =- union+ unionR 8 [ circle 10 , translate (22,0) $ circle 10 , translate (0,22) $ circle 10@@ -34,23 +34,29 @@ , translate (0,-22) $ circle 10 ] +-- | An extruded version of obj2d_1, should be identical to the website's example, and example5.escad. object1 :: SymbolicObj3-object1 = extrudeRM 0 (Just twist) Nothing Nothing obj2d_1 (Left 40)+object1 = extrudeRM 0 (Right twist) (Left 1) (Left (0,0)) obj2d_1 (Left 40) where twist :: ℝ -> ℝ twist h = 35*cos(h*2*pi/60) +-- | another 3D object, for benchmarking. object2 :: SymbolicObj3 object2 = squarePipe (10,10,10) 1 100- where squarePipe (x,y,z) diameter precision =+ where+ squarePipe :: (ℝ,ℝ,ℝ) -> ℝ -> ℝ -> SymbolicObj3+ squarePipe (x,y,z) diameter precision = union- $ map (\start-> translate start+ ((\start-> translate start $ rect3R 0 (0,0,0) (diameter,diameter,diameter) )- $ zip3 (map (\n->(n/precision)*x) [0..precision])- (map (\n->(n/precision)*y) [0..precision])- (map (\n->(n/precision)*z) [0..precision])+ <$>+ zip3 (fmap (\n->(fromIntegral n/precision)*x) [0..100::Fastℕ])+ (fmap (\n->(fromIntegral n/precision)*y) [0..100::Fastℕ])+ (fmap (\n->(fromIntegral n/precision)*z) [0..100::Fastℕ])) +-- | A third 3d object to benchmark. object3 :: SymbolicObj3 object3 = difference@@ -58,34 +64,45 @@ , rect3R 1 (0,0,0) (2,2,2) ] -obj2Benchmarks :: String -> SymbolicObj2 -> Benchmark-obj2Benchmarks name obj =+-- | Example 13 - the rounded union of a cube and a sphere.+object4 :: SymbolicObj3+object4 = union [+ rect3R 0 (0,0,0) (20,20,20),+ translate (20,20,20) (sphere 15) ]++-- | Benchmark a 2D object.+obj2Benchmarks :: String -> String -> SymbolicObj2 -> Benchmark+obj2Benchmarks name filename obj = bgroup name [--- bench "SVG write" $ writeSVG 1 "benchmark.svg" obj--- , bench "PNG write" $ writePNG2 1 "benchmark.png" obj--- ,- bench "Get contour" $ nf (symbolicGetContour 1) obj+ bench "SVG write" $ nfAppIO (writeSVG 1 $ filename <> ".svg") obj,+ bench "PNG write" $ nfAppIO (writePNG2 1 $ filename <> ".png") obj,+ bench "DXF write" $ nfAppIO (writeDXF2 1 $ filename <> ".dxf") obj,+ bench "Get contour" $ nf (symbolicGetContour 1) obj ] -obj3Benchmarks :: String -> SymbolicObj3 -> Benchmark-obj3Benchmarks name obj =+-- | Benchmark a 3D object.+obj3Benchmarks :: String -> String -> SymbolicObj3 -> Benchmark+obj3Benchmarks name filename obj = bgroup name [ -- bench "PNG write" $ writePNG3 1 "benchmark.png" obj--- , bench "STL write" $ writeSTL 1 "benchmark.stl" obj--- ,+ bench "STLTEXT write" $ nfAppIO (writeSTL 1 $ filename <> ".stl.text") obj,+ bench "STL write" $ nfAppIO (writeBinSTL 1 $ filename <> ".stl") obj, bench "Get mesh" $ nf (symbolicGetMesh 1) obj ] +-- | Benchmark all of our objects. benchmarks :: [Benchmark] benchmarks =- [ obj3Benchmarks "Object 1" object1- , obj3Benchmarks "Object 2" object2- , obj3Benchmarks "Object 3" object3- , obj2Benchmarks "Object 2d 1" obj2d_1+ [ obj3Benchmarks "Object 1" "example5" object1+ , obj3Benchmarks "Object 2" "object2" object2+ , obj3Benchmarks "Object 3" "object3" object3+ , obj3Benchmarks "Object 4" "object4" object4+ , obj2Benchmarks "Object 2d 1" "example18" obj2d_1 ] +-- | Our entrypoint. Runs all benchmarks. main :: IO () main = defaultMain benchmarks
− programs/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)- ]
+ programs/docgen.hs view
@@ -0,0 +1,165 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Released under the GNU GPL, see LICENSE++-- FIXME: document why we need each of these.+{-# LANGUAGE ScopedTypeVariables #-}++import Prelude(IO, Show, String, Int, Maybe(Just,Nothing), Eq, return, ($), show, fmap, (<>), putStrLn, filter, zip, null, undefined, const, Bool(True,False), fst, (.), head, tail, length, (/=), (+), error)+import Graphics.Implicit.ExtOpenScad.Primitives (primitiveModules)+import Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP,APFailIf,APExample,APTest,APTerminator,APBranch), Symbol(Symbol), OVal(ONModule), SourcePosition(SourcePosition), StateC)++import qualified Control.Exception as Ex (catch, SomeException)+import Control.Monad (forM_)+import Data.Traversable (traverse)++-- | Return true if the argument is of type ExampleDoc.+isExample :: DocPart -> Bool+isExample (ExampleDoc _ ) = True+isExample _ = False++-- | Return true if the argument is of type ArgumentDoc.+isArgument :: DocPart -> Bool+isArgument (ArgumentDoc _ _ _) = True+isArgument _ = False++-- | Return true if the argument is of type Branch.+isBranch :: DocPart -> Bool+isBranch (Branch _) = True+isBranch _ = False++dumpPrimitive :: Symbol -> [DocPart] -> Int -> IO ()+dumpPrimitive (Symbol moduleName) moduleDocList level = do+ let+ examples = filter isExample moduleDocList+ arguments = filter isArgument moduleDocList+ syntaxes = filter isBranch moduleDocList+ moduleLabel = moduleName++ if level /= 0+ then+ putStrLn $ "#" <> moduleLabel+ else+ do+ putStrLn moduleLabel+ putStrLn (fmap (const '-') moduleLabel)+ putStrLn ""++ if null examples+ then+ return ()+ else+ do+ putStrLn "#Examples:\n"+ forM_ examples $ \(ExampleDoc example) ->+ putStrLn $ " * `" <> example <> "`"+ putStrLn ""++ if null arguments+ then+ return ()+ else+ do+ if level /= 0+ then+ putStrLn "##Arguments:\n"+ else+ if null syntaxes+ then+ putStrLn "#Arguments:\n"+ else+ putStrLn "#Shared Arguments:\n"+ forM_ arguments $ \(ArgumentDoc (Symbol name) posfallback description) ->+ case (posfallback, description) of+ (Nothing, "") ->+ putStrLn $ " * `" <> name <> "`"+ (Just fallback, "") ->+ putStrLn $ " * `" <> name <> " = " <> fallback <> "`"+ (Nothing, _) -> do+ putStrLn $ " * `" <> name <> "`"+ putStrLn $ " " <> description+ (Just fallback, _) -> do+ putStrLn $ " * `" <> name <> " = " <> fallback <> "`"+ putStrLn $ " " <> description+ putStrLn ""++ if null syntaxes+ then+ return ()+ else+ forM_ syntaxes $ \(Branch syntax) ->+ dumpPrimitive (Symbol $ "Syntax " <> show (level+1)) syntax (level+1)++-- | Our entrypoint. Generate one document describing all of our primitives.+main :: IO ()+main = do+ docs <- traverse (getArgParserDocs.getArgParserFrom) primitiveModules+ let+ names = fmap fst primitiveModules+ docname = "ImplicitCAD Primitives"+ putStrLn (fmap (const '=') docname)+ putStrLn docname+ putStrLn (fmap (const '=') docname)+ putStrLn ""+ putStrLn ""+ forM_ (zip names docs) $ \(moduleName, moduleDocList) ->+ dumpPrimitive moduleName moduleDocList 0+ where+ getArgParserFrom :: (Symbol, OVal) -> ArgParser(StateC [OVal])+ getArgParserFrom (_, ONModule _ implementation _) = implementation sourcePosition []+ where sourcePosition = SourcePosition 0 0 "docgen"+ getArgParserFrom (_, _) = error "bad value in primitive array."++-- | the format we extract documentation into+data Doc = Doc String [DocPart]+ deriving (Show)++data DocPart = ExampleDoc String+ | ArgumentDoc Symbol (Maybe String) String+ | Branch [DocPart]+ | Empty+ deriving (Show, Eq)++-- Here there be dragons!+-- Because we made this a Monad instead of applicative functor, there's no 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(s)+ -> IO [DocPart] -- ^ Docs (sadly IO wrapped)++getArgParserDocs (AP name fallback doc fnext) = do+ otherDocs <- Ex.catch (getArgParserDocs $ fnext undefined) (\(_ :: Ex.SomeException) -> return [])+ if otherDocs /= [Empty]+ then+ return $ ArgumentDoc name (fmap show fallback) doc : otherDocs+ else+ return [ArgumentDoc name (fmap show fallback) doc]++getArgParserDocs (APFailIf _ _ child) = getArgParserDocs child++getArgParserDocs (APExample 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 (APTest _ _ child) = getArgParserDocs child++-- To look at this one would almost certainly be death (exception)+getArgParserDocs (APTerminator _) = return [Empty]++-- This one confuses me.+getArgParserDocs (APBranch children) = do+ putStrLn $ show $ length children+ otherDocs <- Ex.catch (getArgParserDocs (APBranch $ tail children)) (\(_ :: Ex.SomeException) -> return [])+ aResults <- getArgParserDocs $ head children+ if otherDocs /= [Empty]+ then+ return [Branch (aResults <> otherDocs)]+ else+ return aResults
programs/extopenscad.hs view
@@ -3,27 +3,26 @@ -- Copyright (C) 2014 2016, Mike MacHenry (mike.machenry@gmail.com) -- Released under the GNU GPL, see LICENSE --- FIXME: add support for AMF.--- An interpreter to run extended OpenScad code, outputing STL, OBJ, SVG, SCAD, PNG, or GCODE.+-- An interpreter to run extended OpenScad code. outputs STL, OBJ, SVG, SCAD, PNG, DXF, or GCODE. -- Enable additional syntax to make our code more readable.-{-# LANGUAGE ViewPatterns , PatternGuards #-}+{-# LANGUAGE ViewPatterns #-} -- 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)+import Prelude (Read(readsPrec), Maybe(Just, Nothing), IO, Bool(True, False), FilePath, Show, Eq, String, (<>), ($), (*), (/), (==), (>), (**), (-), readFile, minimum, drop, error, fmap, fst, min, sqrt, tail, take, length, putStrLn, show, (>>=), lookup, return, unlines, filter, not, null, (||), (&&), (.)) -- 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)+import Graphics.Implicit (runOpenscad, writeSVG, writeDXF2, writeBinSTL, writeSTL, writeOBJ, writeSCAD2, writeSCAD3, writeGCodeHacklabLaser, writePNG2, writePNG3) -- 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, ℝ)+import Graphics.Implicit.Definitions (SymbolicObj2(UnionR2), SymbolicObj3(UnionR3), ℝ) -- Use default values when a Maybe is Nothing.-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, maybe) -- For making the format guesser case insensitive when looking at file extensions. import Data.Char (toLower)@@ -32,49 +31,52 @@ import Data.Tuple (swap) -- Functions and types for dealing with the types used by runOpenscad.--- Note that Map is different than the maps used by the prelude functions.-import qualified Data.Map.Strict as Map (Map, lookup)-import Graphics.Implicit.ExtOpenScad.Definitions (OVal (ONum)) +-- The definition of the symbol type, so we can access variables, and see the requested resolution.+import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup, OVal(ONum), lookupVarIn, Message(Message), MessageType(TextOut), ScadOpts(ScadOpts))+ -- 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 ((<$>), (<*>))+import Control.Applicative ((<$>), (<*>), many) --- 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)+import Options.Applicative (fullDesc, header, auto, info, helper, help, str, argument, long, short, option, metavar, execParser, Parser, optional, strOption, switch, footer) -- For handling input/output files. import System.FilePath (splitExtension) --- The following is needed to ensure backwards/forwards compatibility--- Backwards compatibility with old versions of Data.Monoid:-infixr 6 <>-(<>) :: Monoid a => a -> a -> a-(<>) = mappend+-- For handling handles to output files.+import System.IO (Handle, hPutStr, stdout, stderr, openFile, IOMode(WriteMode)) --- A datatype for containing our command line options.+-- | Our command line options. data ExtOpenScadOpts = ExtOpenScadOpts { outputFile :: Maybe FilePath , outputFormat :: Maybe OutputFormat , resolution :: Maybe ℝ+ , messageOutputFile :: Maybe FilePath+ , quiet :: Bool+ , openScadCompatibility :: Bool+ , openScadEcho :: Bool+ , rawEcho :: Bool+ , noImport :: Bool+ , rawDefines :: [String] , inputFile :: FilePath } --- A datatype enumerating our output file formats types.+-- | A type serving to enumerate our output formats. data OutputFormat = SVG | SCAD | PNG | GCode+ | ASCIISTL | STL | OBJ--- | AMF- deriving (Show, Eq, Ord)+-- | 3MF+ | DXF+ deriving (Show, Eq) --- A list mapping file extensions to output formats.+-- | A list mapping file extensions to output formats. formatExtensions :: [(String, OutputFormat)] formatExtensions = [ ("svg", SVG)@@ -83,26 +85,28 @@ , ("ngc", GCode) , ("gcode", GCode) , ("stl", STL)+ , ("stl.text", ASCIISTL) , ("obj", OBJ)--- , ("amf", AMF)+-- , ("3mf", 3MF)+ , ("dxf", DXF) ] --- Lookup an output format for a given output file. Throw an error if one cannot be found.+-- | Lookup an output format for a given output file. Throw an error if one cannot be found. guessOutputFormat :: FilePath -> OutputFormat guessOutputFormat fileName =- fromMaybe (error $ "Unrecognized output format: "<>ext)+ fromMaybe (error $ "Unrecognized output format: " <> ext) $ readOutputFormat $ tail ext where (_,ext) = splitExtension fileName --- The parser for our command line arguments.+-- | The parser for our command line arguments. extOpenScadOpts :: Parser ExtOpenScadOpts extOpenScadOpts = ExtOpenScadOpts <$> optional ( strOption ( short 'o' <> long "output"- <> metavar "FILE"+ <> metavar "OUTFILE" <> help "Output file name" ) )@@ -119,20 +123,56 @@ ( short 'r' <> long "resolution" <> metavar "RES"- <> help "Approximation quality (smaller is better)"+ <> help "Mesh granularity (smaller values generate more precise renderings of objects)" ) )+ <*> optional (+ strOption+ ( short 'e'+ <> long "echo-output"+ <> metavar "ECHOOUTFILE"+ <> help "Output file name for text generated by the extended OpenSCAD code"+ )+ )+ <*> switch+ ( short 'q'+ <> long "quiet"+ <> help "Supress normal program output, only outputting messages resulting from the parsing or execution of extended OpenSCAD code"+ )+ <*> switch+ ( short 'O'+ <> long "fopenscad-compat"+ <> help "Favour compatibility with OpenSCAD semantics, where they are incompatible with ExtOpenScad semantics"+ )+ <*> switch+ ( long "fopenscad-echo"+ <> help "Use OpenSCAD's style when displaying text output from the extended OpenSCAD code"+ )+ <*> switch+ ( long "fraw-echo"+ <> help "Do not use any prefix when displaying text output from the extended OpenSCAD code"+ )+ <*> switch+ ( long "fno-import"+ <> help "Do not honor \"use\" and \"include\" statements, and instead generate a warning"+ )+ <*> many (+ strOption+ ( short 'D'+ <> help "define variable KEY equal to variable VALUE when running extended OpenSCAD code"+ )+ ) <*> argument str ( metavar "FILE" <> help "Input extended OpenSCAD file" ) --- Try to look up an output format from a supplied extension.+-- | Try to look up an output format from a supplied extension. readOutputFormat :: String -> Maybe OutputFormat-readOutputFormat ext = lookup (map toLower ext) formatExtensions+readOutputFormat ext = lookup (fmap toLower ext) formatExtensions --- A Read instance for our output format. Used by 'auto' in our command line parser.--- Reads a string, and evaluates to the appropriate OutputFormat.+-- | A Read instance for our output format. Used by 'auto' in our command line parser.+-- Reads a string, and evaluates to the appropriate OutputFormat. instance Read OutputFormat where readsPrec _ myvalue = tryParse formatExtensions@@ -144,58 +184,96 @@ then [(result, drop (length attempt) myvalue)] else tryParse xs --- Find the resolution to raytrace at.-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.--- FIXME: magic numbers.-getRes (varlookup, _, obj:_) =+-- | Find the resolution to raytrace at.+getRes :: (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]) -> ℝ+-- | If specified, use a resolution specified by the "$res" a variable in the input file.+getRes (lookupVarIn "$res" -> Just (ONum res), _, _, _) = res+-- | If there was no resolution specified, use a resolution chosen for 3D objects.+-- FIXME: magic numbers.+getRes (vars, _, obj:objs, _) = let- ((x1,y1,z1),(x2,y2,z2)) = getBox3 obj+ ((x1,y1,z1),(x2,y2,z2)) = getBox3 (UnionR3 0 (obj:objs)) (x,y,z) = (x2-x1, y2-y1, z2-z1)- in case fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of+ in case fromMaybe (ONum 1) $ lookupVarIn "$quality" vars 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:_, _) =+-- | ... Or use a resolution chosen for 2D objects.+-- FIXME: magic numbers.+getRes (vars, obj:objs, _, _) = let- (p1,p2) = getBox2 obj+ (p1,p2) = getBox2 (UnionR2 0 (obj:objs)) (x,y) = p2 .-. p1- in case fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of+ in case fromMaybe (ONum 1) $ lookupVarIn "$quality" vars 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.+-- | fallthrough value. getRes _ = 1 --- Output a file containing a 3D object.+-- | Output a file containing a 3D object. export3 :: Maybe OutputFormat -> ℝ -> FilePath -> SymbolicObj3 -> IO () export3 posFmt res output obj = case posFmt of- Just STL -> writeBinSTL res output obj- Just SCAD -> writeSCAD3 res output obj- Just OBJ -> writeOBJ res output obj- Just PNG -> writePNG3 res output obj- Nothing -> writeBinSTL res output obj- Just fmt -> putStrLn $ "Unrecognized 3D format: "<>show fmt+ Just ASCIISTL -> writeSTL res output obj+ Just STL -> writeBinSTL res output obj+ Just SCAD -> writeSCAD3 res output obj+ Just OBJ -> writeOBJ res output obj+ Just PNG -> writePNG3 res output obj+ Nothing -> writeBinSTL res output obj+ Just fmt -> putStrLn $ "Unrecognized 3D format: " <> show fmt --- Output a file containing a 2D object.+-- | Output a file containing a 2D object. export2 :: Maybe OutputFormat -> ℝ -> FilePath -> SymbolicObj2 -> IO () export2 posFmt res output obj = case posFmt of Just SVG -> writeSVG res output obj+ Just DXF -> writeDXF2 res output obj Just SCAD -> writeSCAD2 res output obj Just PNG -> writePNG2 res output obj Just GCode -> writeGCodeHacklabLaser res output obj Nothing -> writeSVG res output obj- Just fmt -> putStrLn $ "Unrecognized 2D format: "<>show fmt+ Just fmt -> putStrLn $ "Unrecognized 2D format: " <> show fmt --- Interpret arguments, and render the object defined in the supplied input file.-run :: ExtOpenScadOpts -> IO()-run args = do+-- | Determine where to direct the text output of running the extopenscad program.+messageOutputHandle :: ExtOpenScadOpts -> IO Handle+messageOutputHandle args = maybe (return stdout) (`openFile` WriteMode) (messageOutputFile args) - putStrLn "Loading File."+textOutOpenScad :: Message -> String+textOutOpenScad (Message _ _ msg) = "ECHO: " <> msg++textOutBare :: Message -> String+textOutBare (Message _ _ msg) = show msg++isTextOut :: Message -> Bool+isTextOut (Message TextOut _ _ ) = True+isTextOut _ = False++objectMessage :: String -> String -> String -> String -> String -> String+objectMessage dimensions infile outfile res box =+ "Rendering " <> dimensions <> " object from " <> infile <> " to " <> outfile <> " with resolution " <> res <> " in box " <> box++-- using the openscad compat group turns on openscad compatibility options. using related extopenscad options turns them off.+-- FIXME: allow processArgs to generate messages.+processArgs :: ExtOpenScadOpts -> ExtOpenScadOpts+processArgs (ExtOpenScadOpts o f r e q compat echo rawecho noimport defines file) =+ ExtOpenScadOpts o f r e q compat echo_flag rawecho noimport defines file+ where+ echo_flag = (compat || echo) && not rawecho++-- | decide what options to send the scad engine based on the post-processed arguments passed to extopenscad.+generateScadOpts :: ExtOpenScadOpts -> ScadOpts+generateScadOpts args = ScadOpts (openScadCompatibility args) (not $ noImport args)++-- | Interpret arguments, and render the object defined in the supplied input file.+run :: ExtOpenScadOpts -> IO ()+run rawargs = do+ let args = processArgs rawargs++ hMessageOutput <- messageOutputHandle args++ if quiet args+ then return ()+ else putStrLn "Loading File."+ content <- readFile (inputFile args) let format =@@ -203,45 +281,92 @@ _ | Just fmt <- outputFormat args -> Just fmt _ | Just file <- outputFile args -> Just $ guessOutputFormat file _ -> Nothing- putStrLn "Processing File."+ scadOpts = generateScadOpts args+ openscadProgram = runOpenscad scadOpts (rawDefines args) content - case runOpenscad content of- Left err -> print err- Right openscadProgram -> do- s@(_, obj2s, obj3s) <- openscadProgram- 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)- Nothing -> Nothing -- We don't know the format -- it will be 2D/3D default- case (obj2s, obj3s) of- ([], [obj]) -> do- let output = fromMaybe- (basename ++ "." ++ fromMaybe "stl" posDefExt)- (outputFile args)- putStrLn $ "Rendering 3D object to " ++ output- putStrLn $ "With resolution " ++ show res- putStrLn $ "In box " ++ show (getBox3 obj)- print obj- export3 format res output obj- ([obj], []) -> do- let output = fromMaybe- (basename ++ "." ++ fromMaybe "svg" posDefExt)- (outputFile args)- putStrLn $ "Rendering 2D object to " ++ output- putStrLn $ "With resolution " ++ show res- putStrLn $ "In box " ++ show (getBox2 obj)- print obj- export2 format res output obj- ([], []) -> putStrLn "No objects to render."- _ -> putStrLn "Multiple/No objects, what do you want to render?"+ if quiet args+ then return ()+ else putStrLn "Processing File." --- The entry point. Use the option parser then run the extended OpenScad code.-main :: IO()+ s@(_, obj2s, obj3s, messages) <- openscadProgram+ let res = fromMaybe (getRes s) (resolution args)+ basename = fst (splitExtension $ inputFile args)+ posDefExt = case format of+ Just f -> Prelude.lookup f (fmap swap formatExtensions)+ Nothing -> Nothing -- We don't know the format -- it will be 2D/3D default++ case (obj2s, obj3s) of+ ([], obj:objs) -> do+ let output = fromMaybe+ (basename <> "." <> fromMaybe "stl" posDefExt)+ (outputFile args)+ target = if null objs+ then obj+ else UnionR3 0 (obj:objs)++ if quiet args+ then return ()+ else putStrLn $ objectMessage "3D" (inputFile args) output (show res) $ show $ getBox3 target++ -- FIXME: construct and use a warning for this.+ if null objs+ then return ()+ else+ hPutStr stderr "WARNING: Multiple objects detected. Adding a Union around them.\n"++ if quiet args+ then return ()+ else putStrLn $ show target++ export3 format res output target++ (obj:objs, []) -> do+ let output = fromMaybe+ (basename <> "." <> fromMaybe "svg" posDefExt)+ (outputFile args)+ target = if null objs+ then obj+ else UnionR2 0 (obj:objs)++ if quiet args+ then return ()+ else putStrLn $ objectMessage "2D" (inputFile args) output (show res) $ show $ getBox2 target++ -- FIXME: construct and use a warning for this.+ if null objs+ then return ()+ else+ hPutStr stderr "WARNING: Multiple objects detected. Adding a Union around them.\n"++ if quiet args+ then return ()+ else putStrLn $ show target++ export2 format res output target++ ([], []) ->+ if quiet args+ then return ()+ else putStrLn "No objects to render."+ _ -> hPutStr stderr "ERROR: File contains a mixture of 2D and 3D objects, what do you want to render?\n"++ -- | Always display our warnings, errors, and other non-textout messages on stderr.+ hPutStr stderr $ unlines $ show <$> filter (not . isTextOut) messages++ let textOutHandler =+ case () of+ _ | openScadEcho args -> textOutOpenScad+ _ | rawEcho args -> textOutBare+ _ -> show++ hPutStr hMessageOutput $ unlines $ textOutHandler <$> filter isTextOut messages++-- | The entry point. Use the option parser then run the extended OpenScad code.+main :: IO () main = execParser opts >>= run where opts= info (helper <*> extOpenScadOpts) ( fullDesc- <> progDesc "ImplicitCAD: Extended OpenSCAD interpreter." - <> header "extopenscad - Extended OpenSCAD"+ <> header "ImplicitCAD: extopenscad - Extended OpenSCAD interpreter."+ <> footer "License: The GNU AGPL version 3 or later <http://gnu.org/licenses/agpl.html> This program is Free Software; you are free to view, change and redistribute it. There is NO WARRANTY, to the extent permitted by law." )
programs/implicitsnap.hs view
@@ -2,18 +2,17 @@ -- Copyright (C) 2014 2015, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- Allow us to use explicit foralls when writing function type declarations.-{-# LANGUAGE ExplicitForAll #-}-+-- FIXME: what are these for? {-# LANGUAGE OverloadedStrings #-}- {-# LANGUAGE ViewPatterns #-} -- A Snap(HTTP) server providing an ImplicitCAD REST API. +-- FIXME: we need AuthN/AuthZ for https://github.com/kliment/explicitcad to be useful.+ -- 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 Prelude (IO, Maybe(Just, Nothing), String, Bool(True, False), Show, ($), (<>), (>), (.), (-), (/), (*), (**), (==), null, sqrt, min, max, minimum, maximum, show, return, fmap, otherwise, filter, not) import Control.Applicative ((<|>)) @@ -24,47 +23,52 @@ -- Our Extended OpenScad interpreter, and the extrudeR function for making 2D objects 3D. import Graphics.Implicit (runOpenscad, extrudeR) -import Graphics.Implicit.ExtOpenScad.Definitions (OVal (ONum))+-- Variable access functionality, so we can look up a requested resolution, along with message processing, and options into the scad engine.+import Graphics.Implicit.ExtOpenScad.Definitions (OVal(ONum), VarLookup, lookupVarIn, Message, Message(Message), MessageType(TextOut), ScadOpts(ScadOpts)) -- 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, ℝ)+import Graphics.Implicit.Definitions (SymbolicObj2(UnionR2), SymbolicObj3(UnionR3), ℝ, Polyline, TriangleMesh) -- Use default values when a Maybe is Nothing.-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, maybe) import Graphics.Implicit.Export.TriangleMeshFormats (jsTHREE, stl)-import Graphics.Implicit.Export.PolylineFormats (svg, hacklabLaserGCode)+--import Graphics.Implicit.Export.NormedTriangleMeshFormats (obj) +import Graphics.Implicit.Export.PolylineFormats (svg, dxf2, 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) -import Data.String (IsString)-import Data.Map.Strict as Map (lookup, Map)+import Data.Text.Lazy (Text) -import Text.ParserCombinators.Parsec (errorPos, sourceLine)-import Text.ParserCombinators.Parsec.Error (errorMessages, showErrorMessages)+import Data.List (intercalate) +import Data.String (IsString)+ import System.IO.Unsafe (unsafePerformIO)-import System.IO.Silently (capture) import qualified Data.ByteString.Char8 as BS.Char (pack, unpack) import qualified Data.Text.Lazy as TL (unpack) +-- | The entry point. uses snap to serve a website. main :: IO () main = quickHttpServe site +-- | Our site definition. Renders requests to "render/", discards all else. site :: Snap () site = route [ ("render/", renderHandler) ] <|> writeBS "fall through" +-- | Our render/ handler. Uses source, callback, and opitional format to render an object. renderHandler :: Snap () renderHandler = method GET $ withCompression $ do modifyResponse $ setContentType "application/x-javascript"@@ -83,69 +87,63 @@ (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:_) =+-- | Find the resolution to raytrace at.+getRes :: (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]) -> ℝ+-- | If specified, use a resolution specified by the "$res" a variable in the input file.+getRes (lookupVarIn "$res" -> Just (ONum res), _, _, _) = res+-- | If there was no resolution specified, use a resolution chosen for 3D objects.+-- FIXME: magic numbers.+getRes (vars, _, obj:objs, _) = let- ((x1,y1,z1),(x2,y2,z2)) = getBox3 obj+ ((x1,y1,z1),(x2,y2,z2)) = getBox3 (UnionR3 0 (obj:objs)) (x,y,z) = (x2-x1, y2-y1, z2-z1)- in case fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of+ in case fromMaybe (ONum 1) $ lookupVarIn "$quality" vars 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:_, _) =+ _ -> min (minimum [x,y,z]/2) ((x*y*z)**(1/3) / 22)+-- | ... Or use a resolution chosen for 2D objects.+-- FIXME: magic numbers.+getRes (vars, obj:objs, _, _) = let- (p1,p2) = getBox2 obj+ (p1,p2) = getBox2 (UnionR2 0 (obj:objs)) (x,y) = p2 .-. p1- in case fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of+ in case fromMaybe (ONum 1) $ lookupVarIn "$quality" vars 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.+ _ -> 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- Just (ONum n) | n >= 1 -> n- _ -> 1- (defaultRes, qualRes) = case (obj2s, obj3s) of- (_, obj:_) -> ( min (minimum [x,y,z]/2) ((x*y*z )**(1/3) / 22)- , min (minimum [x,y,z]/2) ((x*y*z/qual)**(1/3) / 22))- where- ((x1,y1,z1),(x2,y2,z2)) = getBox3 obj- (x,y,z) = (x2-x1, y2-y1, z2-z1)- (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)- _ -> (1, 1)- in case Map.lookup "$res" varlookup of- Just (ONum requestedRes) ->- if defaultRes <= 30*requestedRes- then requestedRes- else -1- _ ->- if qual <= 30- then qualRes- else -1--}+-- | get the maximum dimension of the object being rendered.+-- FIXME: shouldn't this get the diagonal across the box?+getWidth :: (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]) -> ℝ+getWidth (_, _, obj:objs, _) = maximum [x2-x1, y2-y1, z2-z1]+ where ((x1,y1,z1),(x2,y2,z2)) = getBox3 $ UnionR3 0 (obj:objs)+getWidth (_, obj:objs, _, _) = max (x2-x1) (y2-y1)+ where ((x1,y1),(x2,y2)) = getBox2 $ UnionR2 0 (obj:objs)+getWidth (_, [], [], _) = 0 -getWidth :: forall t. (t, [SymbolicObj2], [SymbolicObj3]) -> ℝ-getWidth (_, _, obj:_) = maximum [x2-x1, y2-y1, z2-z1]- where ((x1,y1,z1),(x2,y2,z2)) = getBox3 obj-getWidth (_, obj:_, _) = max (x2-x1) (y2-y1)- where ((x1,y1),(x2,y2)) = getBox2 obj-getWidth (_, [], []) = 0+getOutputHandler2 :: String -> ([Polyline] -> Text)+getOutputHandler2 name+ | name == "SVG" = svg+ | name == "gcode/hacklab-laser" = hacklabLaserGCode+ | otherwise = dxf2 +-- FIXME: OBJ support+getOutputHandler3 :: String -> (TriangleMesh -> Text)+getOutputHandler3 name+ | name == "STL" = stl+ | otherwise = jsTHREE++isTextOut :: Message -> Bool+isTextOut (Message TextOut _ _ ) = True+isTextOut _ = False++-- | decide what options to send to the scad engine.+generateScadOpts :: ScadOpts+generateScadOpts = ScadOpts compat_flag import_flag+ where+ compat_flag = False -- Do not try to be extra compatible with openscad.+ import_flag = False -- Do not honor include or use statements.+ -- | Give an openscad object to run and the basename of -- the target to write to... write an object! executeAndExport :: String -> String -> Maybe String -> String@@ -156,54 +154,57 @@ showB False = "false" callbackF :: Bool -> Bool -> ℝ -> String -> String callbackF False is2D w msg =- callback ++ "([null," ++ show msg ++ "," ++ showB is2D ++ "," ++ show w ++ "]);"+ 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 ->- let- line = sourceLine . errorPos $ err- showErrorMessages' = showErrorMessages- "or" "unknown parse error" "expecting" "unexpected" "end of input"- msgs :: String- msgs = showErrorMessages' $ errorMessages err- in callbackF False False 1 $ (\s-> "error (" ++ show line ++ "):" ++ s) msgs- Right openscadProgram -> unsafePerformIO $ do- (msgs,s) <- capture openscadProgram- let- res = getRes s- w = getWidth s- is2D = case s of- (_, _, _:_) -> False- (_, _:_, _) -> True- _ -> False- highResError = "Unreasonable resolution requested: "- ++ "the server imps revolt! "- ++ "(Install ImplicitCAD locally -- github.com/colah/ImplicitCAD/)"- objOrErr = case s of- (_, _, x:_) ->- if res > 0- then Right (Nothing, x)- else Left highResError- (_, x:_, _) ->- if res > 0- then Right (Just x, extrudeR 0 x res)- else Left highResError- _ -> Left $ msgs ++ "Nothing to render."+ callback <> "([new Shape()," <> show msg <> "," <> showB is2D <> "," <> show w <> "]);"+ callbackS :: (Show a1, Show a) => a -> a1 -> String+ callbackS str msg =+ callback <> "([" <> show str <> "," <> show msg <> ",null,null]);"+ scadOptions = generateScadOpts+ openscadProgram = runOpenscad scadOptions [] content+ in+ unsafePerformIO $ do+ s@(_, obj2s, obj3s, messages) <- openscadProgram+ let+ res = getRes s+ w = getWidth s+ resError :: String+ resError = "Unreasonable resolution requested: "+ <> "the server imps revolt! "+ <> "(Install ImplicitCAD locally -- github.com/colah/ImplicitCAD/)"+ render = res > 0+ scadMessages = intercalate "\n"+ (fmap show (filter (not . isTextOut) messages) <>+ fmap show (filter isTextOut messages)) - return $ case (objOrErr, maybeFormat) of- (Left errmsg, _) -> callbackF False False 1 errmsg- (Right (_,obj), Nothing) ->- TL.unpack (jsTHREE (discreteAprox res obj)) ++ callbackF True is2D w msgs- (Right (_,obj), Just "STL") ->- callbackS (TL.unpack (stl (discreteAprox res obj))) msgs- (Right (Just obj, _), Just "SVG") ->- 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"+ return $ case (obj2s, obj3s, render) of+ (_ , _, False) -> callbackF False False 1 resError+ ([], obj:objs, _ ) -> do+ let target = if null objs+ then obj+ else UnionR3 0 (obj:objs)+ unionWarning :: String+ unionWarning = if null objs+ then ""+ else " \nWARNING: Multiple objects detected. Adding a Union around them."+ output3d = TL.unpack $ maybe jsTHREE getOutputHandler3 maybeFormat $ discreteAprox res target+ if fromMaybe "jsTHREE" maybeFormat == "jsTHREE"+ then output3d <> callbackF True False w (scadMessages <> unionWarning)+ else callbackS output3d (scadMessages <> unionWarning)+ (obj:objs, [] , _) -> do+ let target = if null objs+ then obj+ else UnionR2 0 (obj:objs)+ unionWarning :: String+ unionWarning = if null objs+ then ""+ else " \nWARNING: Multiple objects detected. Adding a Union around them."+ output3d = TL.unpack $ maybe jsTHREE getOutputHandler3 maybeFormat $ discreteAprox res $ extrudeR 0 target res+ output2d = TL.unpack $ maybe svg getOutputHandler2 maybeFormat $ discreteAprox res target+ if fromMaybe "jsTHREE" maybeFormat == "jsTHREE"+ then output3d <> callbackF True True w (scadMessages <> unionWarning)+ else callbackS output2d (scadMessages <> unionWarning)+ ([], [] , _) -> callbackF False False 1 $ intercalate "\n" [scadMessages, "Nothing to render."]+ _ -> callbackF False False 1 $ intercalate "\n" [scadMessages, "ERROR: File contains a mixture of 2D and 3D objects, what do you want to render?"]
+ programs/parser-bench.hs view
@@ -0,0 +1,155 @@+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)+-- Copyright (C) 2016, Kelvin Cookshaw (kelvin@cookshaw.com)+-- Copyright 2014-2019, Julia Longtin (julial@turinglace.com)+-- Released under the GNU AGPLV3+, see LICENSE++import Prelude (IO, String, Int, Either(Left, Right), return, show, ($), otherwise, (==), (-), (<>), mod, concat, error)+import Criterion.Main (Benchmark, bgroup, defaultMain, bench, env, whnf)+import Graphics.Implicit.ExtOpenScad.Definitions (Expr, StatementI)+import Graphics.Implicit.ExtOpenScad.Parser.Expr (expr0)+import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram)+import Text.ParserCombinators.Parsec (parse)+import Text.Printf (printf)++lineComment :: Int -> String+lineComment width = "//" <> ['x' | _ <- [1..width]] <> "\n"++lineComments :: Int -> String+lineComments n = concat [lineComment 80 | _ <- [1..n]]++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]]++throwAway :: Int -> String+throwAway n = concat ["%cube (10);*cube (10);" | _ <- [1..n]]++include :: Int -> String+include n = concat ["include <header.escad>;" | _ <- [1..n]]++use :: Int -> String+use n = concat ["use <header.escad>;" | _ <- [1..n]]++assignments :: Int -> String+assignments n = concat ["x = (foo + bar);\n" | _ <- [1..n]]++functionDeclarations :: Int -> String+functionDeclarations n = concat ["function functionname(arg, arg2) = sin(arg*arg2);" | _ <- [1..n]]++echos :: Int -> String+echos n = concat ["echo(" <> show x <> ");" | x <- [1..n]]++ifs :: Int -> String+ifs n = concat ["if (true) {cube (10);} else {cube (20);}" | _ <- [1..n]]++fors :: Int -> String+fors n = concat ["for (i=[0:1:10]) {cube (i);}" | _ <- [1..n]]++moduleCalls :: Int -> String+moduleCalls n = concat ["moduleno" <> show x <> " (" <> show x <> ");" | x <- [1..n]]++moduleDeclarations :: Int -> String+moduleDeclarations n = concat ["module modulename(arg, arg2=10) { cube(arg2); }" | _ <- [1..n]]++ternary :: Int -> String+ternary n = concat ["true?1:" | _ <- [1..n]] <> "2"++lets :: Int -> String+lets n = concat ["let (a=1) " | _ <- [1..n]] <> " a"++intList :: Int -> String+intList n = "[" <> concat [show i <> "," | i <- [1..n]] <> "0]"++intParList :: Int -> String+intParList n = "(" <> concat [show i <> "," | i <- [1..n]] <> "0)"++intPosNegList :: Int -> String+intPosNegList n = "[" <> concat [posOrNeg i <> show i <> "," | i <- [1..n]] <> "0]"+ where+ posOrNeg :: Int -> String+ posOrNeg x = if x `mod` 2 == 1+ then "+"+ else "-"++parExpr :: Int -> String+parExpr n = concat ["(a+" <> show i <> "+" | i <- [0..n]] <> "0)" <> concat ["+" <> show i <> ")" | i <- [1..n]]++genList :: Int -> String+genList n = concat ["[1:1:" <> show i <> "] ++ " | i <- [1..n]] <> "0"++stringList :: Int -> String+stringList n = "[" <> concat ["\"" <> show i <> "\", " | i <- [1..n]] <> " \"something\"]"++boolList :: Int -> String+boolList n = "[" <> concat [trueOrFalse i <> "," | i <- [1..n]] <> "false]"+ where+ trueOrFalse :: Int -> String+ trueOrFalse x = if x `mod` 2 == 1+ then "true"+ else "false"++undefinedList :: Int -> String+undefinedList n = "[" <> concat ["undef, " | _ <- [1..n]] <> "undef]"++deepArithmetic :: Int -> String+deepArithmetic n+ | n == 0 = "1"+ | otherwise = printf "%s + %s * (%s - %s)" d d d d+ where+ d = deepArithmetic (n - 1)++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 "noname" s of+ Left err -> error (show err)+ Right e -> e++run :: String -> (String -> a) -> String -> Benchmark+run name func input =+ env (return input) $ \s ->+ bench name $ whnf func s++main :: IO ()+main =+ defaultMain+ [ bgroup "lexer" [+ bgroup "comments"+ [ run "line" parseStatements (lineComments 5000)+ , run "block" parseStatements (blockComments 10 500)+ ]+ ]+ , bgroup "statement" [+ run "throwAway" parseStatements (throwAway 500)+ , bgroup "includes"+ [ run "include" parseStatements (include 5000)+ , run "use" parseStatements (use 5000)+ ]+ , run "assignments" parseStatements (assignments 50)+ , run "function declarations" parseStatements (functionDeclarations 100)+ , run "echos" parseStatements (echos 1000)+ , run "ifs" parseStatements (ifs 250)+ , run "fors" parseStatements (fors 50)+ , run "module calls" parseStatements (moduleCalls 500)+ , run "module declarations" parseStatements (moduleDeclarations 500)+ ]+ , bgroup "expression" [+ run "ternary operators" parseExpr (ternary 500)+ , run "let statements" parseExpr (lets 3)+ , run "int list" parseExpr (intList 100)+ , run "parenthesized int list" parseExpr (intParList 100)+ , run "parenthesized expression" parseExpr (parExpr 2)+ , run "generated list" parseExpr (genList 50)+ , run "list of positive or negative integers" parseExpr (intPosNegList 100)+ , run "string list" parseExpr (stringList 100)+ , run "bool list" parseExpr (boolList 100)+ , run "undefined list" parseExpr (undefinedList 100)+ , run "deep arithmetic" parseExpr (deepArithmetic 3)+ ]+ ]
− stack.yaml
@@ -1,29 +0,0 @@-# 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/ExecSpec/Expr.hs view
@@ -0,0 +1,28 @@+-- 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 ExecSpec.Expr (exprExec) where++-- Be explicit about what we import.+import Prelude (($))++-- Hspec, for writing specs.+import Test.Hspec (describe, Spec, it)++-- The type used for variables, in ImplicitCAD.+import Graphics.Implicit.Definitions (ℝ)++-- Our utility library, for making these tests easier to read.+import ExecSpec.Util ((-->), num)++-- Default all numbers in this file to being of the type ImplicitCAD uses for values.+default (ℝ)++exprExec :: Spec+exprExec =+ describe "arithmatic" $ do+ it "performs simple addition" $+ "1+1" --> num 2+ it "performs multiple addition" $+ "1+1+1" --> num 3
+ tests/ExecSpec/Util.hs view
@@ -0,0 +1,35 @@+-- 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++-- Utilities+module ExecSpec.Util+ ( (-->)+ , num+ ) where++-- be explicit about where we get things from.+import Prelude (String)++-- The datatype of positions in our world.+import Graphics.Implicit.Definitions (ℝ)++-- Expressions, symbols, and values in the OpenScad language.+import Graphics.Implicit.ExtOpenScad.Definitions (OVal(ONum))+++import Graphics.Implicit.ExtOpenScad.Eval.Constant (runExpr)++import Test.Hspec (Expectation, shouldBe)++-- An operator for expressions for "the left side should evaluate to the right side."+infixr 1 -->+(-->) :: String -> OVal -> Expectation+(-->) source value =+ runExpr source `shouldBe` (value, [])++-- | Types++num :: ℝ -> OVal+num = ONum
tests/Main.hs view
@@ -8,15 +8,25 @@ -- our testing engine. import Test.Hspec(hspec, describe) --- the test forstatements.+-- the parser test for statements. import ParserSpec.Statement(statementSpec) --- the test for expressions.+-- the parser test for expressions. import ParserSpec.Expr(exprSpec) +-- the execution test for expressions.+import ExecSpec.Expr(exprExec)++-- the execution test for warnings.+import MessageSpec.Message(programExec)+ main :: IO () main = hspec $ do- -- run tests against the expression engine.- describe "expressions" exprSpec- -- and now, against the statement engine.- describe "statements" statementSpec+ -- run tests against the expression parsing engine.+ describe "expression parsing" exprSpec+ -- and now, against the statement parsing engine.+ describe "statements parsing" statementSpec+ -- run tests against the expression execution engine. single statements.+ describe "expression execution" exprExec+ -- run tests against the evaluation engine, checking for messages.+ describe "program execution" programExec
+ tests/MessageSpec/Message.hs view
@@ -0,0 +1,36 @@+-- 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 MessageSpec.Message (programExec) where++-- Be explicit about what we import.+import Prelude (($))++-- Hspec, for writing specs.+import Test.Hspec (describe, Spec, it)++-- The types used for variables, in ImplicitCAD.+import Graphics.Implicit.Definitions (Fastℕ, ℝ)++import Graphics.Implicit.ExtOpenScad.Definitions (MessageType(TextOut), SourcePosition(SourcePosition))++-- Our utility library, for making these tests easier to read.+import MessageSpec.Util ((-->), oneMessage)++-- Default all numbers in this file to being of the type ImplicitCAD uses for values.+default (Fastℕ, ℝ)++programExec :: Spec+programExec =+ describe "arithmatic" $ do+ it "echoes simple addition" $+ "echo(1+1);" --> oneMessage TextOut (SourcePosition 1 1 []) "2.0"+ it "calls a no argument function" $+ "module a(){echo(1);}a();" --> oneMessage TextOut (SourcePosition 1 12 []) "1.0"+ it "calls a single argument function" $+ "module a(b){echo(b);}a(1);" --> oneMessage TextOut (SourcePosition 1 13 []) "1.0"+ it "calls a function with a named and an unnamed argument" $+ "module a(b,c){echo(b+c);}a(b=1,1);" --> oneMessage TextOut (SourcePosition 1 15 []) "2.0"+-- it "warns about a missing argument" $+-- "module a(b){echo(b);}a();" --> oneMessage TextOut (SourcePosition 1 13 []) "1.0"
+ tests/MessageSpec/Util.hs view
@@ -0,0 +1,45 @@+-- 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++-- Utilities+module MessageSpec.Util+ ( (-->)+ , oneMessage+ ) where++-- be explicit about where we get things from.+import Prelude (String, Bool(False), IO, return)++-- Expressions, symbols, and values in the OpenScad language.+import Graphics.Implicit.ExtOpenScad.Definitions (ScadOpts(ScadOpts), MessageType, Message(Message), SourcePosition)++import Graphics.Implicit.ExtOpenScad (runOpenscad)++import Test.Hspec (Expectation, shouldReturn)++-- | decide what options to send to the scad engine.+generateScadOpts :: ScadOpts+generateScadOpts = ScadOpts compat_flag import_flag+ where+ compat_flag = False -- Do not try to be extra compatible with openscad.+ import_flag = False -- Do not honor include or use statements.++-- An operator for expressions for "the left side should evaluate to the right side."+infixr 1 -->+(-->) :: String -> [Message] -> Expectation+(-->) source value =+ getOpenscadMessages scadOptions [] source `shouldReturn` value+ where+ scadOptions = generateScadOpts+-- | Types++-- | An even smaller wrapper which runs a program, and only returns the generated messages. for the test suite.+getOpenscadMessages :: ScadOpts -> [String] -> String -> IO [Message]+getOpenscadMessages scadOpts constants source = do+ (_, _, _, messages) <- runOpenscad scadOpts constants source+ return messages++oneMessage :: MessageType -> SourcePosition -> String -> [Message]+oneMessage msgType pos text = [Message msgType pos text]
− tests/NOTES
@@ -1,2 +0,0 @@--https://github.com/nmz787/microfluidic-cad: GPLV2 or greater
tests/ParserSpec/Expr.hs view
@@ -2,50 +2,46 @@ -- Copyright (C) 2014-2017, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE +-- Allow us to use shorter forms of Var and Name.+{-# LANGUAGE PatternSynonyms #-}+ module ParserSpec.Expr (exprSpec) where -- Be explicit about what we import.-import Prelude (String, Bool(True, False), ($), (<*), )+import Prelude (Bool(True, False), String, ($)) -- 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 Test.Hspec (describe, Expectation, Spec, it, pendingWith, specify) -import ParserSpec.Util (fapp, num, bool, plus, minus, mult, modulo, power, divide, negate, and, or, gt, lt, ternary, append, index, parseWithLeftOver)+-- Parsed expression components.+import Graphics.Implicit.ExtOpenScad.Definitions (Expr(ListE, (:$)), Symbol(Symbol)) -import Data.Either (Either(Right))+import qualified Graphics.Implicit.ExtOpenScad.Definitions as GIED (Expr(Var), Pattern(Name)) -import Text.ParserCombinators.Parsec (parse, eof)+-- The type used for variables, in ImplicitCAD.+import Graphics.Implicit.Definitions (ℝ) --- 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+-- Our utility library, for making these tests easier to read.+import ParserSpec.Util ((-->), fapp, num, bool, stringLiteral, undefined, plus, minus, mult, power, divide, negate, and, or, not, gt, ternary, append, index, lambda) --- 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)+-- Default all numbers in this file to being of the type ImplicitCAD uses for values.+default (ℝ) -ternaryIssue :: Expectation -> Expectation-ternaryIssue _ = pendingWith "parser doesn't handle ternary operator correctly"+-- Let us use the old syntax when defining Vars and Names.+pattern Var :: String -> Expr+pattern Var s = GIED.Var (Symbol s)+pattern Name :: String -> GIED.Pattern+pattern Name n = GIED.Name (Symbol n) -negationIssue :: Expectation -> Expectation-negationIssue _ = pendingWith "parser doesn't handle negation operator correctly"+undefinedIssue :: Expectation -> Expectation+undefinedIssue _ = pendingWith "this errors, but the expecting is equal to the recieved. huh?" logicalSpec :: Spec logicalSpec = do describe "not" $ do- specify "single" $ "!foo" --> negate [Var "foo"]- specify "multiple" $- negationIssue $ "!!!foo" --> negate [negate [negate [Var "foo"]]]+ specify "single" $ "!foo" --> not [Var "foo"]+ specify "double" $ "!!foo" --> Var "foo"+ specify "tripple" $ "!!!foo" --> not [Var "foo"] it "handles and/or" $ do "foo && bar" --> and [Var "foo", Var "bar"] "foo || bar" --> or [Var "foo", Var "bar"]@@ -55,21 +51,56 @@ 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)]+ "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]]+ "1 > 0 ? 5 : 1 + 2" -->+ ternary [gt [num 1, num 0], num 5, plus [num 1, num 2]]+ specify "nested in true and false expressions" $+ "c0 ? c1 ? t1 : f1 : c2 ? t2 : f2" -->+ ternary [Var "c0", ternary [Var "c1",Var "t1",Var "f1"], ternary [Var "c2",Var "t2",Var "f2"]] literalSpec :: Spec literalSpec = do it "handles integers" $- "12356" --> num 12356+ "12356" --> num 12356+ it "handles positive leading zero integers" $+ "000012356" --> num 12356+ it "handles zero integer" $+ "0" --> num 0+ it "handles leading zero integer" $+ "0000" --> num 0 it "handles floats" $- "23.42" --> num 23.42+ "23.42" --> num 23.42+ it "handles floats with no whole component" $+ ".2342" --> num 0.2342+ describe "E notation" $ do+ it "accepts integer e with positive sign" $ "1e+1" --> num 10+ it "accepts integer e with negative sign" $ "10e-1" --> num 1+ it "accepts integer e with no sign" $ "1e1" --> num 10+ it "accepts floating e with positive sign" $ "1.1e+1" --> num 11+ it "accepts floating e with negative sign" $ "1.28e-1" --> num 0.128+ it "accepts floating e with no sign" $ "1.1e1" --> num 11 describe "booleans" $ do it "accepts true" $ "true" --> bool True it "accepts false" $ "false" --> bool False+ describe "undefined" $+ it "accepts undef" $ undefinedIssue $ "undef" --> undefined +letBindingSpec :: Spec+letBindingSpec = do+ it "handles let with integer binding and spaces" $+ "let ( a = 1 ) a" --> lambda [Name "a"] (Var "a") [num 1]+ it "handles multiple variable let" $+ "let (a = x, b = y) a + b" --> lambda [Name "a"] (lambda [Name "b"] (plus [Var "a", Var "b"]) [Var "y"]) [Var "x"]+ it "handles empty let" $+ "let () a" --> Var "a"+ it "handles nested let" $+ "let(a=x) let(b = y) a + b" --> lambda [Name "a"] (lambda [Name "b"] (plus [Var "a", Var "b"]) [Var "y"]) [Var "x"]+ it "handles let on right side of an arithmetic operator" $+ "1 + let(b = y) b" --> plus [num 1, lambda [Name "b"] (Var "b") [Var "y"]]+ it "handles let on right side of a unary negation" $+ "- let(b = y) b" --> negate [lambda [Name "b"] (Var "b") [Var "y"]]+ exprSpec :: Spec exprSpec = do describe "literals" literalSpec@@ -79,51 +110,83 @@ "foo_bar" --> Var "foo_bar" describe "grouping" $ do it "allows parens" $- "( false )" --> bool False+ "( false )" --> bool False+ it "handles empty vectors" $+ "[]" --> ListE []+ it "handles single element vectors" $+ "[a]" --> ListE [Var "a"] it "handles vectors" $- "[ 1, 2, 3 ]" --> ListE [num 1, num 2, num 3]+ "[ 1, 2, 3 ]" --> ListE [num 1, num 2, num 3]+ it "handles nested vectors" $+ "[ 1, [2, 7], [3, 4, 5, 6] ]" --> ListE [num 1, ListE [num 2, num 7], ListE [num 3, num 4, num 5, num 6]] it "handles lists" $- "( 1, 2, 3 )" --> ListE [num 1, num 2, num 3]+ "( 1, 2, 3 )" --> ListE [num 1, num 2, num 3] it "handles generators" $- "[ a : 1 : b + 10 ]" -->+ "[ a : b ]" -->+ fapp "list_gen" [Var "a", num 1, Var "b"]+ it "handles generators with expression" $+ "[ a : b + 10 ]" --> fapp "list_gen" [Var "a", num 1, plus [Var "b", num 10]]+ it "handles increment generators" $+ "[ a : 3 : b + 10 ]" -->+ fapp "list_gen" [Var "a", num 3, plus [Var "b", num 10]] it "handles indexing" $ "foo[23]" --> index [Var "foo", num 23]+ it "handles multiple indexes" $+ "foo[23][12]" --> Var "index" :$ [Var "index" :$ [Var "foo", num 23], num 12]+ it "handles single function/module call with single argument" $+ "foo(1)" --> Var "foo" :$ [num 1]+ it "handles single function/module call with multiple arguments" $+ "foo(1, 2, 3)" --> Var "foo" :$ [num 1, num 2, num 3] describe "arithmetic" $ do- it "handles unary +/-" $ do+ it "handles unary -" $ "-42" --> num (-42)- "+42" --> num 42+ it "handles unary +" $+ "+42" --> num 42+ it "handles unary - with extra spaces" $+ "- 42" --> num (-42)+ it "handles unary + with extra spaces" $+ "+ 42" --> num 42+ it "handles unary - with parentheses" $+ "-(4 - 3)" --> negate [ minus [num 4, num 3]]+ it "handles unary + with parentheses" $+ "+(4 - 1)" --> minus [num 4, num 1]+ it "handles unary - with identifier" $+ "-foo" --> negate [Var "foo"]+ it "handles unary + with identifier" $+ "+foo" --> Var "foo"+ it "handles unary - with string literal" $+ "-\"foo\"" --> negate [stringLiteral "foo"]+ it "handles unary + with string literal" $+ "+\"foo\"" --> stringLiteral "foo" it "handles +" $ do "1 + 2" --> plus [num 1, num 2]- "1 + 2 + 3" --> plus [num 1, num 2, num 3]+ "1 + 2 + 3" --> plus [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]]+ "1 + 2 - 3" --> minus [plus [num 1, 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]]+ "1 + 2 - 3 + 4" --> plus [minus [ plus [num 1, num 2], num 3], num 4]+ "1 + 2 - 3 + 4 - 5 - 6" --> minus [minus [plus [minus [plus [num 1, num 2], num 3], 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]+ "x ^ y" --> power [Var "x", Var "y"]+ it "handles multiple exponentiations" $+ "x ^ y ^ z" --> power [Var "x", power [Var "y", Var "z"]]+ it "handles *" $+ "3 * 4" --> mult [num 3, num 4]+ it "handles > 2 term *" $+ "3 * 4 * 5" --> mult [mult [num 3, num 4], num 5] it "handles /" $- "4.2 / 2.3" --> divide [num 4.2, num 2.3]+ "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"]+ "foo ++ bar ++ baz" --> append [append [Var "foo", Var "bar"], Var "baz"] describe "logical operators" logicalSpec- describe "application" $ do+ describe "let expressions" letBindingSpec+ describe "function/module 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
@@ -2,57 +2,67 @@ -- Copyright (C) 2014-2017, Julia Longtin (julial@turinglace.com) -- Released under the GNU AGPLV3+, see LICENSE --- statement related hspec tests.+-- Allow us to use shorter forms of Var and Name.+{-# LANGUAGE PatternSynonyms #-}++-- | Statement related hspec tests. module ParserSpec.Statement (statementSpec) where -import Prelude (String, Maybe(Just), Bool(True), ($))+import Prelude (String, Maybe(Just, Nothing), Bool(True), ($)) -import Test.Hspec (Spec, Expectation, shouldBe, shouldSatisfy, it, pendingWith, describe)+import Test.Hspec (Spec, Expectation, shouldBe, it, describe) --- import Text.ParserCombinators.Parsec ()+import ParserSpec.Util (bool, num, minus, plus, mult, index) -import ParserSpec.Util (bool, num, minus, mult, index)+import Graphics.Implicit.ExtOpenScad.Definitions (StatementI(StatementI), Symbol(Symbol), Expr(ListE, LamE, (:$)), Statement(NewModule, ModuleCall, If, (:=)), Pattern(ListP), SourcePosition(SourcePosition)) -import Graphics.Implicit.ExtOpenScad.Definitions (StatementI(StatementI), Symbol, Expr(ListE, LamE, Var), Statement(NewModule, ModuleCall, If, (:=)), Pattern(Name, ListP))+import qualified Graphics.Implicit.ExtOpenScad.Definitions as GIED (Expr(Var), Pattern(Name)) -- Parse an ExtOpenScad program. import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram) -import Data.Either (Either(Right), isLeft)+import Graphics.Implicit.Definitions (Fastℕ) --- an expectation that a string become a statement.+import Data.Either (Either(Right))++-- Let us use the old syntax when defining Vars and Names.+pattern Var :: String -> Expr+pattern Var s = GIED.Var (Symbol s)+pattern Name :: String -> Pattern+pattern Name n = GIED.Name (Symbol n)++-- | an expectation that a string is equivalent to a statement. infixr 1 --> (-->) :: String -> [StatementI] -> Expectation (-->) source stmts =- parseProgram source `shouldBe` Right stmts+ parseProgram "noname" source `shouldBe` Right stmts --- an expectation that a string generates an error.-parsesAsError :: String -> Expectation-parsesAsError source = parseProgram source `shouldSatisfy` isLeft+-- | an expectation that a string generates an error.+-- parsesAsError :: String -> Expectation+-- parsesAsError source = parseProgram "noname" source `shouldSatisfy` isLeft +-- | A single statement. 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)+single st = [StatementI (SourcePosition 1 1 "noname") st] --- test a simple if block.-ifSpec :: Spec-ifSpec = it "parses" $- "if (true) { a(); } else { b(); }" --> - single ( If (bool True) [call "a" [] []] [call "b" [] []])+-- | A function call.+call :: String -> Fastℕ -> [(Maybe Symbol, Expr)] -> [StatementI] -> StatementI+call name column args stmts = StatementI (SourcePosition 1 column "noname") (ModuleCall (Symbol name) args stmts) --- test assignments.+-- | Test assignments. assignmentSpec :: Spec assignmentSpec = do- it "parses correctly" $- "y = -5;" --> single ( Name "y" := num (-5))+ it "handles assignment" $+ "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];" -->+ "[ x , y ] = [ 1 , 2 ] ; " --> single (ListP [Name "x", Name "y"] := ListE [num 1, num 2])+ it "handles the function keyword" $+ "function foo ( x , y ) = x * y ; " --> single fooFunction+ it "handles function with let expression" $+ "function withlet ( b ) = let ( c = 5 ) b + c ; " -->+ single (Name "withlet" := LamE [Name "b"] (LamE [Name "c"] (plus [Var "b", Var "c"]) :$ [num 5]))+ it "handles nested indexing" $+ "x = [ y [ 0 ] - z * 2 ] ; " --> single ( Name "x" := ListE [minus [index [Var "y", num 0], mult [Var "z", num 2]]]) where@@ -60,34 +70,46 @@ fooFunction = Name "foo" := LamE [Name "x", Name "y"] (mult [Var "x", Var "y"]) -emptyFileIssue :: Expectation -> Expectation-emptyFileIssue _ = pendingWith "parser should probably allow empty files"-+-- | Test a simple if block.+ifSpec :: Spec+ifSpec = do+ it "parses" $+ "if ( true ) { a ( ) ; }" -->+ single ( If (bool True) [call "a" 15 [] []] [])+ it "parses with else clause" $+ "if ( true ) { a ( ) ; } else {b();}" -->+ single ( If (bool True) [call "a" 15 [] []] [call "b" 31 [] []]) +-- | Our entry point. Test all of the statements. 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" [] [])+ it "returns an empty list" $ "" --> []+ describe "assignment" assignmentSpec+ describe "if" ifSpec+ describe "line comment" $+ it "parses as empty" $ "// foish bar \n " --> []+ describe "multiline comment" $+ it "parses as empty" $ "/* foish bar\n */ " --> []+ describe "module call" $+ it "parses" $ "foo ( ) ; " --> single (ModuleCall (Symbol "foo") [] [])+ describe "disabled module call" $+ it "parses as empty" $ "% foo ( ) ; " --> [] describe "difference of two cylinders" $ it "parses correctly" $- "difference(){ cylinder(r=5,h=20); cylinder(r=2,h=20); }"+ "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)]+ ModuleCall (Symbol "difference") [] [+ call "cylinder" 18 [(Just (Symbol "r"), num 5.0),+ (Just (Symbol "h"), num 20.0)] [],- call "cylinder" [(Just "r", num 2.0),- (Just "h", num 20.0)]+ call "cylinder" 47 [(Just (Symbol "r"), num 2.0),+ (Just (Symbol "h"), num 20.0)] []])- describe "empty module definition" $+ describe "module definition" $ do it "parses correctly" $- "module foo_bar() {}" --> single (NewModule "foo_bar" [] [])--+ "module foo_bar ( ) { }" --> single (NewModule (Symbol "foo_bar") [] [])+ it "accepts argument" $+ "module foo_bar ( x ) { }" --> single (NewModule (Symbol "foo_bar") [(Symbol "x", Nothing)] [])+ it "accepts argument with default" $+ "module foo_bar ( x = 1) { }" --> single (NewModule (Symbol "foo_bar") [(Symbol "x", Just $ num 1)] [])
tests/ParserSpec/Util.hs view
@@ -3,13 +3,13 @@ -- 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+ ( (-->)+ , num , bool+ , stringLiteral+ , undefined , fapp , plus , minus@@ -17,30 +17,49 @@ , modulo , power , divide- , negate+ , not , and , or , gt , lt+ , negate , ternary , append , index+ , lambda , parseWithLeftOver ) where -- be explicit about where we get things from.-import Prelude (Bool, String, Either, (<), ($), (.), otherwise)+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))+-- Expressions, symbols, and values in the OpenScad language.+import Graphics.Implicit.ExtOpenScad.Definitions (Expr(LitE, (:$), Var, ListE, LamE), Symbol(Symbol), OVal(ONum, OBool, OString, OUndefined), Pattern) -import Text.ParserCombinators.Parsec (Parser, ParseError, parse, manyTill, anyChar, eof)+import Text.Parsec (ParseError, parse, manyTill, anyChar, eof) +import Text.Parsec.String (Parser)+ import Control.Applicative ((<$>), (<*>)) +import Test.Hspec (Expectation, shouldBe)++import Data.Either (Either(Right))++-- The expression parser entry point.+import Graphics.Implicit.ExtOpenScad.Parser.Expr (expr0)++-- 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++-- | Types+ num :: ℝ -> Expr num x -- FIXME: the parser should handle negative number literals@@ -51,26 +70,38 @@ bool :: Bool -> Expr bool = LitE . OBool -plus,minus,mult,modulo,power,divide,negate,and,or,gt,lt,ternary,append,index :: [Expr] -> Expr+stringLiteral :: String -> Expr+stringLiteral = LitE . OString++undefined :: Expr+undefined = LitE OUndefined++-- | Operators++plus,minus,mult,modulo,power,divide,negate,and,or,not,gt,lt,ternary,append,index :: [Expr] -> Expr minus = oapp "-" modulo = oapp "%" power = oapp "^"+mult = oapp "*" divide = oapp "/" and = oapp "&&" or = oapp "||"+not = oapp "!" gt = oapp ">" lt = oapp "<" ternary = oapp "?"-negate = oapp "!"+negate = oapp "negate" index = oapp "index"-plus = fapp "+"-mult = fapp "*"-append = fapp "++"+append = oapp "++"+plus = oapp "+" --- we need two different kinds of application functions+-- | We need two different kinds of application functions, one for operators, and one for functions. oapp,fapp :: String -> [Expr] -> Expr-oapp name args = Var name :$ args-fapp name args = Var name :$ [ListE args]+oapp name args = Var (Symbol name) :$ args+fapp name args = Var (Symbol name) :$ [ListE args]++lambda :: [Pattern] -> Expr -> [Expr] -> Expr+lambda params expr args = LamE params expr :$ args parseWithLeftOver :: Parser a -> String -> Either ParseError (a, String) parseWithLeftOver p = parse ((,) <$> p <*> leftOver) ""
− tests/tobacco_mesophyll_protoplast_fusion_device.escad
@@ -1,493 +0,0 @@-// 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- );-