Merge branch 'master' into master

.gitignore

@@ -7,3 +7,6 @@
 *.stl
 dist/
 Setup
+docs/iscad.md
+.stack-work/
+Examples/*cachegrind*

CONTRIBUTORS

@@ -20,6 +20,8 @@ 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
+cookshak -- Kelvin Cookshaw -- kelvin@cookshaw.com
+kpe -- ?? -- ??
 
 Thanks as well, to raghuugare. Due to not being contactable,
 his code has been removed during the license update.

Examples/example11.hs

@@ -6,4 +6,4 @@ out = union [
        translate (40,40) (circle 30) ]
 
 main = writeSVG 2 "example11.svg" out
-             
+

Examples/example12.hs

@@ -4,5 +4,5 @@ import Graphics.Implicit
 out = unionR 14 [
                   rectR 0 (-40,-40) (40,40),
                   translate (40,40) (circle 30) ]
-          
+
 main = writeSVG 2 "example12.svg" out

Examples/example14.escad

@@ -0,0 +1,10 @@
+// example7.escad -- A twisted rounded extrusion of the rounded union of 5 hexagonical solids.
+linear_extrude (height = 40, center=true, twist=90, r=5){
+        union ( r = 8) {
+                circle (10,$fn=6);
+                translate ([22,0]) circle (10,$fn=6);
+                translate ([0,22]) circle (10,$fn=6);
+                translate ([-22,0]) circle (10,$fn=6);
+                translate ([0,-22]) circle (10,$fn=6);
+        }
+}

Examples/example15.scad

@@ -0,0 +1,4 @@
+difference() {
+sphere(20);
+cylinder(r=17, h=100, center = true);
+}

Examples/example16.hs

@@ -0,0 +1,8 @@
+import Graphics.Implicit
+import Graphics.Implicit.Definitions
+import Graphics.Implicit.Primitives
+
+roundbox:: SymbolicObj3
+roundbox = implicit (\(x,y,z) -> (x^4 + y^4 + z^4 - 15000)) ((-20,-20,-20),(20,20,20))
+
+main = writeSTL 2 "example16.stl" roundbox

Examples/example17.hs

@@ -0,0 +1,21 @@
+-- Example 17, pulled from our benchmarking suite.
+import Graphics.Implicit
+import Graphics.Implicit.Definitions
+
+default (Fastℕ, ℝ)
+
+object2 :: SymbolicObj3
+object2 = squarePipe (10,10,10) 1 100
+    where
+      squarePipe :: (ℝ,ℝ,ℝ) -> ℝ -> ℝ -> SymbolicObj3
+      squarePipe (x,y,z) diameter precision =
+            union
+            $ map (\start-> translate start
+                   $ rect3R 0 (0,0,0) (diameter,diameter,diameter)
+                  )
+            $ zip3 (map (\n->((fromIntegral n)/precision)*x) [0..100])
+                   (map (\n->((fromIntegral n)/precision)*y) [0..100])
+                   (map (\n->((fromIntegral n)/precision)*z) [0..100])
+
+main = writeSTL 1 "example17.stl" object2
+

Graphics/Implicit.hs

@@ -3,69 +3,43 @@
 -- Released under the GNU AGPLV3+, see LICENSE
 
 -- FIXME: Required. why?
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
 
 {- The purpose of this file is to pass on the functionality we want
    to be accessible to an end user who is compiling objects using
    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)
+
+-- typesclasses and types defining the world, or part of the world.
+import Graphics.Implicit.Definitions as W (ℝ, SymbolicObj2, SymbolicObj3)
 
 -- 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)
-
--- Datatypes/classes defining the world, or part of the world.
-import Graphics.Implicit.Definitions (ℝ, SymbolicObj2, SymbolicObj3)
+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)
@@ -73,6 +47,9 @@ import Graphics.Implicit.Definitions (ℝ, SymbolicObj2, SymbolicObj3)
 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

@@ -1,30 +1,36 @@
 -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
--- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)
+-- Copyright 2014 2015 2016, 2017, 2018, Julia Longtin (julial@turinglace.com)
 -- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com)
 -- Released under the GNU AGPLV3+, see LICENSE
 
 -- This module deliberately declares orphan instances of Show.
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
+-- Allow us to use explicit foralls when writing function type declarations.
+{-# LANGUAGE ExplicitForAll #-}
+
 -- Required. FIXME: why?
 {-# 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ℝ,
-    ℕ,
     (⋅),
     (⋯*),
     (⋯/),
-    Polyline,
-    Triangle,
-    NormedTriangle,
-    TriangleMesh,
-    NormedTriangleMesh,
+    Polyline(Polyline),
+    Polytri(Polytri),
+    Triangle(Triangle),
+    NormedTriangle(NormedTriangle),
+    TriangleMesh(TriangleMesh),
+    NormedTriangleMesh(NormedTriangleMesh),
     Obj2,
     Obj3,
     Box2,
@@ -67,38 +73,70 @@ module Graphics.Implicit.Definitions (
         ExtrudeRM,
         ExtrudeOnEdgeOf,
         RotateExtrude),
-    Rectilinear2,
-    Rectilinear3,
+    fromℕtoℝ,
+    fromFastℕtoℝ,
+    fromℝtoFloat
     )
 where
 
-import Prelude (Show, Double, Integer, 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
 minℝ :: ℝ
+-- for Doubles.
+minℝ = 0.0000000000000002
 -- for Floats.
 --minℝ = 0.00000011920928955078125 * 2
 
--- for Doubles.
-minℝ = 0.0000000000000002
+-- | 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)
+{-# INLINABLE both #-}
 
-type ℕ = Integer
+-- | 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)
+{-# INLINABLE allthree #-}
 
--- TODO: Find a better place for this
+-- | TODO: Find a better place for this
 (⋅) :: InnerSpace a => a -> a -> Scalar a
 (⋅) = (<.>)
+{-# INLINABLE (⋅) #-}
 
+-- Wrap the functions that convert datatypes.
 
--- handle additional instances of Show.
+-- | 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.
+fromℝtoFloat :: ℝ -> Float
+fromℝtoFloat = realToFrac
+{-# INLINABLE fromℝtoFloat #-}
+
+-- |add aditional instances to Show, for when we dump the intermediate form of objects.
 instance Show (ℝ -> ℝ) where
     show _ = "<function ℝ>"
 
@@ -117,50 +155,72 @@ instance Show (ℝ3 -> ℝ) where
 --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 (a,b,c) = a triangle with vertices a, b and c
-type Triangle = (ℝ3, ℝ3, ℝ3)
+-- | A triangle in 2D space (a,b,c).
+newtype Polytri = Polytri (ℝ2, ℝ2, ℝ2)
+
+-- | A triangle in 3D space (a,b,c) = a triangle with vertices a, b and c
+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 :)
-type TriangleMesh = [Triangle]
+-- | A triangle mesh is a bunch of triangles, attempting to be a surface.
+newtype TriangleMesh = TriangleMesh [Triangle]
 
--- | A normed triangle mesh is a bunch 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
@@ -170,7 +230,7 @@ type BoxedObj2 = Boxed2 Obj2
 type BoxedObj3 = Boxed3 Obj3
 
 -- | 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 =
@@ -195,11 +255,11 @@ data SymbolicObj2 =
     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]
@@ -219,7 +279,7 @@ data SymbolicObj3 =
     | ExtrudeR ℝ SymbolicObj2 ℝ
     | ExtrudeRotateR ℝ ℝ SymbolicObj2 ℝ
     | ExtrudeRM
-        ℝ                 -- rounding radius
+        ℝ                 -- rounding radius (ignored)
         (Maybe (ℝ -> ℝ))  -- twist
         (Maybe (ℝ -> ℝ))  -- scale
         (Maybe (ℝ -> ℝ2)) -- translate
@@ -227,16 +287,11 @@ data SymbolicObj3 =
         (Either ℝ (ℝ2 -> ℝ)) -- height to extrude to
     | RotateExtrude
         ℝ                     -- Angle to sweep to
-        (Maybe ℝ)             -- Loop or path (rounded corner)
+        (Maybe ℝ)             -- Loop or path (rounded corner) (ignored)
         (Either ℝ2 (ℝ -> ℝ2)) -- translate function
         (Either ℝ  (ℝ -> ℝ )) -- rotate function
         SymbolicObj2          -- object to extrude
     | ExtrudeOnEdgeOf SymbolicObj2 SymbolicObj2
     deriving Show
 
--- | Rectilinear 2D set
-type Rectilinear2 = [Box2]
-
--- | Rectilinear 2D set
-type Rectilinear3 = [Box3]
 

Graphics/Implicit/Export.hs

@@ -6,17 +6,17 @@
 -- 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, (.), ($))
 
 -- The types of our objects (before rendering), and the type of the resolution to render with.
-import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3, ℝ, Polyline, TriangleMesh, Triangle, NormedTriangle)
+import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3, ℝ, Polyline, TriangleMesh, NormedTriangleMesh)
 
--- The functions for writing our output, as well as a type used.
+-- functions for outputing a file, and one of the types.
 import Data.Text.Lazy (Text)
 import qualified Data.Text.Lazy.IO as LT (writeFile)
 import qualified Data.ByteString.Lazy as LBS (writeFile)
@@ -24,25 +24,26 @@ import qualified Data.ByteString.Lazy as LBS (writeFile)
 -- 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 (scad3, scad2)
+import qualified Graphics.Implicit.Export.SymbolicFormats as SymbolicFormats (scad2, scad3)
 import qualified Codec.Picture as ImageFormatCodecs (DynamicImage, savePngImage)
 
--- Write an object using the given format function.
+-- | 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 =
-    let aprox = formatObject res format obj
+writeObject res formatWriter filename obj =
+    let
+        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
@@ -50,26 +51,29 @@ writeObject' :: (DiscreteAproxable obj aprox)
     -> obj              -- ^ Object to render
     -> IO ()            -- ^ Writing Action!
 writeObject' res formatWriter filename obj =
-    let aprox = discreteAprox res obj
-    in formatWriter filename aprox
+    formatWriter filename (discreteAprox res obj)
 
+-- | 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 res = writeObject res PolylineFormats.svg
 
-writeSTL :: forall obj. DiscreteAproxable obj [Triangle] => ℝ -> FilePath -> obj -> IO ()
+writeDXF2 :: forall obj. DiscreteAproxable obj [Polyline] => ℝ -> FilePath -> obj -> IO ()
+writeDXF2 res = writeObject res PolylineFormats.dxf2
+
+writeSTL :: forall obj. DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO ()
 writeSTL res = writeObject res TriangleMeshFormats.stl
 
-writeBinSTL :: forall obj. DiscreteAproxable obj [Triangle] => ℝ -> FilePath -> obj -> IO ()
+writeBinSTL :: forall obj. DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO ()
 writeBinSTL res file obj = LBS.writeFile file $ TriangleMeshFormats.binaryStl $ discreteAprox res obj
 
-writeOBJ :: forall obj. DiscreteAproxable obj [NormedTriangle] => ℝ -> FilePath -> obj -> IO ()
+writeOBJ :: forall obj. DiscreteAproxable obj NormedTriangleMesh => ℝ -> FilePath -> obj -> IO ()
 writeOBJ res = writeObject res NormedTriangleMeshFormats.obj
 
 writeTHREEJS :: forall obj. DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO ()

Graphics/Implicit/Export/DiscreteAproxable.hs

@@ -5,101 +5,117 @@
 -- 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 #-}
 
-module Graphics.Implicit.Export.DiscreteAproxable where
+-- | A module for retrieving approximate represententations of objects.
+module Graphics.Implicit.Export.DiscreteAproxable (DiscreteAproxable, discreteAprox) where
 
-import Prelude(Int, (-), (/), ($), (<), map, round, (+), maximum, abs, (*), fromIntegral, max, realToFrac)
+import Prelude((-), (/), ($), (<), map, round, (+), maximum, abs, (*), fromIntegral, max, realToFrac, Int)
 
-import Graphics.Implicit.Definitions (ℝ, ℝ2, SymbolicObj3, SymbolicObj2, 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.SymbolicObj2 (symbolicGetContour)
+
+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
 
 instance DiscreteAproxable SymbolicObj3 TriangleMesh where
-    discreteAprox res obj = symbolicGetMesh res obj
+    discreteAprox = symbolicGetMesh
 
 instance DiscreteAproxable SymbolicObj3 NormedTriangleMesh where
-    discreteAprox res obj = map (normTriangle res (getImplicit3 obj)) $ symbolicGetMesh res obj
+    discreteAprox res obj = NormedTriangleMesh $ map (normTriangle res (getImplicit3 obj)) $ unmesh $ symbolicGetMesh res obj
 
--- FIXME: magic numbers.
+-- FIXME: way too many magic numbers.
 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 :: Int -> Int -> 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 =
-                    average $ [
-                        traceRay 
+                colorToPixelRGBA8 $
+                    average [
+                        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 res obj = symbolicGetContour res obj
+    discreteAprox = symbolicGetContour
 
 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 :: Int -> Int -> 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',
+                    (a', b') = (realToFrac mya, realToFrac myb) :: ℝ2
+                    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

@@ -2,84 +2,68 @@
 -- 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(Int, Bool(True, False), ceiling, fromIntegral, (/), (+), (-), filter, map, ($), (*), (/=), (<=), (>), (.), splitAt, div, unzip, length, (++), (<), (++), head, concat, not, null, (||), Eq, Int, fst, snd)
+import Prelude(Bool(True, False), ceiling, (/), (+), (-), filter, map, ($), (*), (/=), (<=), (>), splitAt, div, unzip, length, (++), (<), (++), head, ceiling, concat, div, max, not, null, (||), Eq, fromIntegral, floor)
 
-import Graphics.Implicit.Export.Render.HandlePolylines (reducePolyline)
+import Graphics.Implicit.Definitions (ℕ, ℝ, ℝ2, both, Polyline, Obj2, (⋯/), (⋯*))
 
-import Graphics.Implicit.Definitions (ℝ2, Polyline, Obj2, (⋯/), (⋯*))
-
--- FIXME: commented out for now, parallelism is not properly implemented.
--- import Control.Parallel.Strategies (using, parList, rdeepseq)
 import Data.VectorSpace ((^-^), (^+^))
 
-both :: (a -> b) -> (a,a) -> (b,b)
-both f (x,y) = (f x, f y)
+import Data.List(genericIndex)
 
--- | getContour gets a polyline describe the edge of your 2D
---  object. It's really the only function in this file you need
---  to care about from an external perspective.
+import 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, parList)
+
+-- getContour gets a polyline describing the edge of a 2D object.
 getContour :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [Polyline]
-getContour p1 p2 d obj =
+getContour p1 p2 res obj =
     let
-        -- How many steps will we take on each axis?
-        n :: (Int, Int)
-        n =  (ceiling) `both` ((p2 ^-^ p1) ⋯/ d)
-        nx = fst n
-        ny = snd n
-        -- Divide it up and compute the polylines
-        gridPos :: (Int,Int) -> (Int,Int) -> ℝ2
-        gridPos (nx',ny') (mx,my) =
-            let
-                p :: ℝ2
-                p = ( fromIntegral mx / fromIntegral nx'
-                    , fromIntegral my / fromIntegral ny')
-            in
-              p1 ^+^ (p2 ^-^ p1) ⋯* p
-        linesOnGrid :: [[[Polyline]]]
-        linesOnGrid = [[getSquareLineSegs
-                   (gridPos n (mx,my))
-                   (gridPos n (mx+1,my+1))
-                   obj
-             | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]
-        -- Cleanup, cleanup, everybody cleanup!
-        -- (We connect multilines, delete redundant vertices on them, etc)
-        multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLinesDC $ linesOnGrid
-    in
-        multilines
+        -- How much space are we rendering?
+        d = p2 ^-^ p1
 
--- FIXME: Commented out, not used?
-{-
-getContour2 :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [Polyline]
-getContour2 p1@(x1, y1) p2@(x2, y2) d obj =
-    let
         -- How many steps will we take on each axis?
-        n@(nx,ny) = (fromIntegral . ceiling) `both` ((p2 ^-^ p1) ⋯/ d)
-        -- Grid mapping funcs
-        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))
+        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'))
+
+        -- alternate Grid mapping funcs
+        toGrid :: ℝ2 -> (ℕ,ℕ)
+        toGrid f = floor `both` ((fromIntegral `both` n) ⋯* (f ^-^ p1) ⋯/ d)
+
         -- Evaluate obj on a grid, in parallel.
         valsOnGrid :: [[ℝ]]
-        valsOnGrid = [[ obj (fromGrid (mx, my)) | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]
-                      `using` parList rdeepseq
+        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 !! my !! mx where (mx,my) = toGrid p
-        -- Divide it up and compute the polylines
+        preEvaledObj p = valsOnGrid `genericIndex` my `genericIndex` mx where (mx,my) = toGrid p
+
+        -- compute the polylines
         linesOnGrid :: [[[Polyline]]]
-        linesOnGrid = [[getSquareLineSegs (fromGrid (mx, my)) (fromGrid (mx+1, my+1)) preEvaledObj
-             | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]
+        linesOnGrid = [[getSquareLineSegs (gridPos n (mx, my)) (gridPos n (mx+1, my+1)) preEvaledObj
+             | mx <- [0.. nx-1] ] | my <- [0..ny-1] ] `using` parBuffer (max 1 $ fromIntegral $ div ny 32) rdeepseq
+
         -- Cleanup, cleanup, everybody cleanup!
         -- (We connect multilines, delete redundant vertices on them, etc)
-        multilines = (filter polylineNotNull) $ (map reducePolyline) $ orderLinesDC $ linesOnGrid
+        lines = filter polylineNotNull $ map reducePolyline $ orderLinesDC linesOnGrid
     in
-        multilines
--}
+      lines
 
 -- | This function gives line segments to divide negative interior
---  regions and positive exterior ones inside a square, based on its
+--  regions and positive exterior ones inside a square, based on the
 --  values at its vertices.
 --  It is based on the linearly-interpolated marching squares algorithm.
 
@@ -88,11 +72,13 @@ getSquareLineSegs (x1, y1) (x2, y2) obj =
     let
         (x,y) = (x1, y1)
 
-        -- Let's evlauate obj at a few points...
+        -- Let's evlauate obj at four corners...
         x1y1 = obj (x1, y1)
         x2y1 = obj (x2, y1)
         x1y2 = obj (x1, y2)
         x2y2 = obj (x2, y2)
+
+        -- And the center point..
         c = obj ((x1+x2)/2, (y1+y2)/2)
 
         dx = x2 - x1
@@ -111,17 +97,19 @@ getSquareLineSegs (x1, y1) (x2, y2) obj =
         --      ---------*----------
         --             midy1
 
+
         midx1 = (x,                       y + dy*x1y1/(x1y1-x1y2))
         midx2 = (x + dx,                  y + dy*x2y1/(x2y1-x2y2))
         midy1 = (x + dx*x1y1/(x1y1-x2y1), y )
         midy2 = (x + dx*x1y2/(x1y2-x2y2), y + dy)
+
         notPointLine :: Eq a => [a] -> Bool
-        notPointLine (p1:p2:[]) = p1 /= p2
-        notPointLine ([]) = False
-        notPointLine ([_]) = False
-        notPointLine (_ : (_ : (_ : _))) = False
-    in filter (notPointLine) $ case (x1y2 <= 0, x2y2 <= 0,
-                                     x1y1 <= 0, x2y1 <= 0) of
+        notPointLine (start:stop:xs) = start /= stop || notPointLine [stop:xs]
+        notPointLine [_] = False
+        notPointLine [] = False
+
+    in filter notPointLine $ case (x1y2 <= 0, x2y2 <= 0,
+                                   x1y1 <= 0, x2y1 <= 0) of
         -- Yes, there's some symetries that could reduce the amount of code...
         -- But I don't think they're worth exploiting...
         (True,  True,
@@ -162,11 +150,22 @@ getSquareLineSegs (x1, y1) (x2, y2) obj =
             else [[midx1, midy1], [midx2, midy2]]
 
 
-
--- $ Functions for cleaning up the polylines
+-- Functions for cleaning up the polylines.
 -- Many have multiple implementations as efficiency experiments.
 -- At some point, we'll get rid of the redundant ones....
 
+-- FIXME: document the algorithm this uses better.
+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
+
 {-
 orderLines :: [Polyline] -> [Polyline]
 orderLines [] = []
@@ -182,16 +181,6 @@ orderLines (present: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 (\(x,y) -> (halve x, halve y)) . unzip . map (halve) $ segs' of
-            ((a,b),(c,d)) -> orderLinesDC a ++ orderLinesDC b ++ orderLinesDC c ++ orderLinesDC d
-    in
-        if (length segs < 5 || length (head segs) < 5 ) then concat $ concat segs else
-                splitOrder segs
 {-
 orderLinesP :: [[[Polyline]]] -> [Polyline]
 orderLinesP segs =

Graphics/Implicit/Export/MarchingSquaresFill.hs

@@ -5,31 +5,54 @@
 -- Allow us to use explicit foralls when writing function type declarations.
 {-# LANGUAGE ExplicitForAll #-}
 
--- define getContour, which gets a polyline describe the edge of your 2D object.
+-- export getContourMesh, which returns an array of triangles describing the interior of a 2D object.
 module Graphics.Implicit.Export.MarchingSquaresFill (getContourMesh) where
 
-import Prelude(Bool(True, False), fromInteger, ($), (-), (+), (/), (*), (<=), (>), ceiling, concat)
+import Prelude(Bool(True, False), fromIntegral, ($), (-), (+), (/), (*), (<=), (>), ceiling, concat, max, div, floor)
 
-import Graphics.Implicit.Definitions (ℝ, ℝ2, Obj2)
+import Graphics.Implicit.Definitions (ℕ, ℝ, ℝ2, Polytri(Polytri), Obj2, (⋯/), (⋯*))
 
--- FIXME: commented out, test how to apply..
--- import Control.Parallel (par, pseq)
+import Data.VectorSpace ((^-^),(^+^))
 
-getContourMesh :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [(ℝ2,ℝ2,ℝ2)]
-getContourMesh (x1, y1) (x2, y2) (dx, dy) obj =
+import Data.List(genericIndex)
+
+-- Each step on the Y axis is done in parallel using Control.Parallel.Strategies
+import Control.Parallel.Strategies (using, rdeepseq, parBuffer, parList)
+
+-- apply a function to both items in the provided tuple.
+both :: forall t b. (t -> b) -> (t, t) -> (b, b)
+both f (x,y) = (f x, f y)
+
+getContourMesh :: ℝ2 -> ℝ2 -> ℝ2 -> Obj2 -> [Polytri]
+getContourMesh p1 p2 res obj =
     let
+        -- How much space are we rendering?
+        d = p2 ^-^ p1
+
         -- How many steps will we take on each axis?
-        nx :: ℝ
-        nx = fromInteger $ ceiling $ (x2 - x1) / dx
-        ny :: ℝ
-        ny = fromInteger $ ceiling $ (y2 - y1) / dy
-        -- Divide it up and compute the polylines
-        trisOnGrid :: [[[(ℝ2,ℝ2,ℝ2)]]]
-        trisOnGrid = [[getSquareTriangles
-                   (x1 + (x2 - x1)*mx/nx,     y1 + (y2 - y1)*my/ny)
-                   (x1 + (x2 - x1)*(mx+1)/nx, y1 + (y2 - y1)*(my+1)/ny)
-                   obj
-             | mx <- [0.. nx-1] ] | my <- [0..ny-1] ]
+        nx :: ℕ
+        ny :: ℕ
+        n@(nx,ny) = ceiling `both` (d ⋯/ res)
+
+        -- a helper for calculating a position inside of the space.
+        gridPos :: (ℕ,ℕ) -> (ℕ,ℕ) -> ℝ2
+        gridPos n' m = p1 ^+^ d ⋯* ((fromIntegral `both` m) ⋯/ (fromIntegral `both` n'))
+
+        -- alternate Grid mapping funcs
+        toGrid :: ℝ2 -> (ℕ,ℕ)
+        toGrid f = floor `both` ((fromIntegral `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)) preEvaledObj
+             | mx <- [0.. nx-1] ] | my <- [0..ny-1] ] `using` parBuffer (max 1 $ fromIntegral $ div ny 32) rdeepseq
         triangles = concat $ concat trisOnGrid
     in
         triangles
@@ -39,16 +62,18 @@ getContourMesh (x1, y1) (x2, y2) (dx, dy) obj =
 --  values at its vertices.
 --  It is based on the linearly-interpolated marching squares algorithm.
 
-getSquareTriangles :: ℝ2 -> ℝ2 -> Obj2 -> [(ℝ2,ℝ2,ℝ2)]
+getSquareTriangles :: ℝ2 -> ℝ2 -> Obj2 -> [Polytri]
 getSquareTriangles (x1, y1) (x2, y2) obj =
     let
         (x,y) = (x1, y1)
 
-        -- Let's evlauate obj at a few points...
+        -- Let's evaluate obj at four corners...
         x1y1 = obj (x1, y1)
         x2y1 = obj (x2, y1)
         x1y2 = obj (x1, y2)
         x2y2 = obj (x2, y2)
+
+        -- And the center point..
         c = obj ((x1+x2)/2, (y1+y2)/2)
 
         dx = x2 - x1
@@ -56,16 +81,16 @@ getSquareTriangles (x1, y1) (x2, y2) obj =
 
         -- linearly interpolated midpoints on the relevant axis
         --             midy2
-        --      _________*__________
-        --     |                    |
-        --     |                    |
-        --     |                    |
-        --midx1*                    * midx2
-        --     |                    |
-        --     |                    |
-        --     |                    |
-        --     -----------*----------
-        --              midy1
+        --      _________*_________
+        --     |                   |
+        --     |                   |
+        --     |                   |
+        --midx1*                   * midx2
+        --     |                   |
+        --     |                   |
+        --     |                   |
+        --      ---------*---------
+        --             midy1
 
         midx1 = (x,                       y + dy*x1y1/(x1y1-x1y2))
         midx2 = (x + dx,                  y + dy*x2y1/(x2y1-x2y2))
@@ -73,8 +98,8 @@ getSquareTriangles (x1, y1) (x2, y2) obj =
         midy2 = (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
@@ -93,33 +118,30 @@ getSquareTriangles (x1, y1) (x2, y2) obj =
         (True,  False,
          True,  False) -> square (x1,y1) midy1 midy2 (x1,y2)
         (True,  False,
-         False, False) -> [((x1,y2), midx1, midy2)]
+         False, False) -> [Polytri ((x1,y2), midx1, midy2)]
         (False, True,
          True,  True)  ->
-            [(midx1, (x1,y1), midy2), ((x1,y1), (x2,y1), midy2), (midy2, (x2,y1), (x2,y2))]
+            [Polytri (midx1, (x1,y1), midy2), Polytri ((x1,y1), (x2,y1), midy2), Polytri (midy2, (x2,y1), (x2,y2))]
         (True,  True,
          False, True)  ->
-            [((x1,y2), midx1, (x2,y2)), (midx1, midy1, (x2,y2)), ((x2,y2), midy1, (x2,y1))]
+            [Polytri ((x1,y2), midx1, (x2,y2)), Polytri (midx1, midy1, (x2,y2)), Polytri ((x2,y2), midy1, (x2,y1))]
         (False, False,
-         True,  False) -> [(midx1, (x1,y1), midy1)]
+         True,  False) -> [Polytri (midx1, (x1,y1), midy1)]
         (True,  True,
          True,  False) ->
-            [(midy1,midx2,(x2,y2)), ((x2,y2), (x1,y2), midy1), (midy1, (x1,y2), (x1,y1))]
+            [Polytri (midy1,midx2,(x2,y2)), Polytri ((x2,y2), (x1,y2), midy1), Polytri (midy1, (x1,y2), (x1,y1))]
         (False, False,
-         False, True)  -> [(midx2, midy1, (x2,y1))]
+         False, True)  -> [Polytri (midx2, midy1, (x2,y1))]
         (True,  False,
          True,  True)  ->
-            [(midy2, (x2,y1), midx2), ((x2,y1), midy2, (x1,y1)), ((x1,y1), midy2, (x1,y2))]
+            [Polytri (midy2, (x2,y1), midx2), Polytri ((x2,y1), midy2, (x1,y1)), Polytri ((x1,y1), midy2, (x1,y2))]
         (False, True,
-         False, False) -> [(midx2, (x2,y2), midy2)]
+         False, False) -> [Polytri (midx2, (x2,y2), midy2)]
         (True,  False,
          False, True)  -> if c > 0
-            then [((x1,y2), midx1, midy2), ((x2,y1), midy1, midx2)]
+            then [Polytri ((x1,y2), midx1, midy2), Polytri ((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]]
-
-
-
+            else [Polytri ((x1,y1), midy1, midx1), Polytri ((x2,y2), midx2, midy2)] --[[midx1, midy1], [midx2, midy2]]

Graphics/Implicit/Export/NormedTriangleMeshFormats.hs

@@ -9,29 +9,29 @@ module Graphics.Implicit.Export.NormedTriangleMeshFormats (obj) where
 
 import Prelude(($), map, (+), (.), (*), length, (-), return)
 
-import Graphics.Implicit.Definitions (NormedTriangle, ℝ3)
+import Graphics.Implicit.Definitions (NormedTriangle(NormedTriangle), NormedTriangleMesh(NormedTriangleMesh), ℝ3)
 import Graphics.Implicit.Export.TextBuilderUtils (Text, Builder, toLazyText, (<>), bf, mconcat, buildInt)
 
-
-obj :: [NormedTriangle] -> Text
-obj normedtriangles = toLazyText $ vertcode <> normcode <> trianglecode
+-- | Generate a .obformat file from a NormedTriangleMesh
+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 position in the resulting list
             [a,b,c]
         norms = do
-            -- extract the normals for each triangle
-            ((_,a),(_,b),(_,c)) <- normedtriangles
-            -- The normals from each triangle take up 3 position in the resulting list
+            -- | extract the normals for each triangle
+            NormedTriangle ((_,a),(_,b),(_,c)) <- normedtriangles
+            -- | The normals from each triangle take up 3 position in the resulting list
             [a,b,c]
         vertcode = mconcat $ map v verts
         normcode = mconcat $ map n norms

Graphics/Implicit/Export/PolylineFormats.hs

@@ -7,63 +7,142 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 
-module Graphics.Implicit.Export.PolylineFormats where
+module Graphics.Implicit.Export.PolylineFormats (svg, hacklabLaserGCode, dxf2) where
 
-import Prelude((.), ($), (-), (+), (/), minimum, maximum, unzip, concat, show, (++), unwords, map, mapM_, snd, compare, min, max, Ord, Num)
+import Prelude((.), ($), (-), (+), (/), minimum, maximum, unzip, show, (++), unwords, map, mapM_, snd, compare, min, max, length, concat, foldl)
 
-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, mempty, toLazyText, mconcat, 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 qualified Data.List as List
+import Data.List (sortBy)
 
+default (ℝ)
+
+-- FIXME: magic numbers.
 svg :: [Polyline] -> Text
 svg plines = renderSvg . svg11 . svg' $ plines
     where
-      strokeWidth = 1.0
-      (xmin, xmax, ymin, ymax) = ((minimum xs) - margin, (maximum xs) + margin, (minimum ys) - margin, (maximum ys) + margin)
+      strokeWidth :: ℝ
+      strokeWidth = 1
+      (xmin, xmax, ymin, ymax) = (xmin' - margin, xmax' + margin, ymin' - margin, ymax' + margin)
            where margin = strokeWidth / 2
-                 (xs,ys) = unzip (concat plines)
-      
-      svg11 content = docTypeSvg ! A.version "1.1" 
-                                 ! A.width  (stringValue $ show (xmax-xmin) ++ "mm")
-                                 ! A.height (stringValue $ show (ymax-ymin) ++ "mm")
-                                 ! A.viewbox (stringValue $ unwords . map show $ [0,0,xmax-xmin,ymax-ymin])
-                                 $ content
+                 ((xmin', xmax'), (ymin', ymax')) = (maxMinList xs,maxMinList ys)  
+                 (xs,ys) = unzip $ concat $ map 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])
+
       -- 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
 
-      poly line = polyline ! A.points pointList 
+      poly (Polyline line) = polyline ! A.points pointList
           where pointList = toValue $ toLazyText $ mconcat [bf (x-xmin) <> "," <> bf (ymax - y) <> " " | (x,y) <- line]
 
       -- Instead of setting styles on every polyline, we wrap the lines in a group element and set the styles on it:
       thinBlueGroup = g ! A.stroke "rgb(0,0,255)" ! A.strokeWidth (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 = mconcat [
+        "  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 = mconcat [
+        "  0\n",   "SECTION\n",
+        "  2\n",   "TABLES\n",
+        "  0\n",   "ENDSEC\n"
+        ]
+      dxf2Blocks :: Builder
+      dxf2Blocks = mconcat [
+        "  0\n",   "SECTION\n",
+        "  2\n",   "BLOCKS\n",
+        "  0\n",   "ENDSEC\n"
+        ]
+      dxf2Entities :: Builder
+      dxf2Entities = mconcat [
+        "  0\n",   "SECTION\n",
+        "  2\n",   "ENTITIES\n",
+        mconcat [ buildPolyline orderedPolyline | orderedPolyline <- orderPolylines plines],
+        "  0\n",   "ENDSEC\n"
+        ]
+      buildPolyline :: Polyline -> Builder
+      buildPolyline (Polyline singlePolyline) =
+        mconcat [
+        "  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",
+        mconcat [ buildVertex vertex | vertex <- singlePolyline ],
+        "  0\n",   "SEQEND\n"
+        ]
+      buildVertex :: (ℝ2) -> Builder
+      buildVertex (x1,y1) =
+        mconcat [
+        "  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 $ concat $ map pair plines
+      pair :: Polyline -> [ℝ2]
+      pair (Polyline x) = x
+
+orderPolylines :: [Polyline] -> [Polyline]
+orderPolylines plines =
+  map snd . sortBy (\(a,_) (b, _) -> compare a b) . map (\x -> (polylineRadius x, x)) $ plines
+  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 $ concat $ map 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
 hacklabLaserGCode :: [Polyline] -> Text
-hacklabLaserGCode polylines = toLazyText $ gcodeHeader <> mconcat (map interpretPolyline orderedPolylines) <> gcodeFooter
-    where 
-      orderedPolylines =
-            snd . unzip 
-            . List.sortBy (\(a,_) (b, _) -> compare a b)
-            . map (\x -> (polylineRadius x, x))
-            $ polylines
-      polylineRadius :: forall t. (Ord t, Num t) => [(t, t)] -> t
-      polylineRadius [] = 0
-      polylineRadius polyline' = max (xmax' - xmin') (ymax' - ymin') where
-           ((xmin', xmax'), (ymin', ymax')) = polylineRadius' polyline'
-           polylineRadius' :: forall a a1. (Ord a1, Ord a, Num a1, Num a) => [(a, a1)] -> ((a, a), (a1, a1))
-           polylineRadius' [] = ((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
+hacklabLaserGCode polylines = toLazyText $ gcodeHeader <> mconcat (map interpretPolyline (orderPolylines polylines)) <> gcodeFooter
+    where
       gcodeHeader :: Builder
       gcodeHeader = mconcat [
                      "(generated by ImplicitCAD, based of hacklab wiki example)\n"
@@ -79,11 +158,11 @@ hacklabLaserGCode polylines = toLazyText $ gcodeHeader <> mconcat (map interpret
                     ,"M2 (end)"]
       gcodeXY :: ℝ2 -> Builder
       gcodeXY (x,y) = mconcat ["X", buildTruncFloat x, " Y", buildTruncFloat y]
-                      
-      interpretPolyline (start:others) = mconcat [
+      interpretPolyline :: Polyline -> Builder
+      interpretPolyline (Polyline (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 
+      interpretPolyline (Polyline []) = mempty

Graphics/Implicit/Export/RayTrace.hs

@@ -2,65 +2,71 @@
 -- 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 TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts #-}
 
-module Graphics.Implicit.Export.RayTrace where
+module Graphics.Implicit.Export.RayTrace( Color(Color), average, Camera(Camera), Light(Light), Scene(Scene), traceRay, cameraRay) where
 
-import Prelude(Show, RealFrac, Maybe(Just, Nothing), Int, Bool(False, True), (-), (.), ($), (*), (/), min, fromInteger, max, round, fromIntegral, unzip, map, length, sum, maximum, minimum, (>), (+), (<), (==), pred, flip, (++), not, abs, floor, fromIntegral, toRational)
+import Prelude(Show, RealFrac, Maybe(Just, Nothing), Bool(False, True), (-), (.), ($), (*), (/), min, fromInteger, max, round, fromIntegral, unzip, map, length, sum, maximum, minimum, (>), (+), (<), (==), pred, flip, not, abs, floor, toRational, otherwise)
+
+import Graphics.Implicit.Definitions (ℝ, ℕ, ℝ2, ℝ3, (⋅), Obj3)
+
+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.Arrow ((***))
+
 import Data.VectorSpace (Scalar, magnitude, (^+^), (*^), normalized, (^-^), InnerSpace)
+
 import Data.Cross (cross3)
 
+default (ℕ, ℝ)
+
 -- 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
+-- | A light source. source point, and intensity.
+data Light  = Light ℝ3 ℝ
+    deriving Show
 
-color :: Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> PixelRGBA8
-color r g b a = PixelRGBA8 r g b a
-
-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
         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)) = (\(a'',b'') -> (unzip a'', unzip b'')) $ unzip $ map
-            (\(PixelRGBA8 r g b a) -> ((fromIntegral r, fromIntegral g), (fromIntegral b, fromIntegral a)))
-            l :: (([ℝ], [ℝ]), ([ℝ],[ℝ]))
-        n = fromIntegral $ length l :: ℝ
+average l =
+    let
+        ((rs, gs), (bs, as)) = (unzip *** unzip) . unzip $ map
+            (\(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
@@ -74,6 +80,7 @@ cameraRay (Camera p vx vy f) (x,y) =
     in
         Ray p' n
 
+-- | Create a ray from two points.
 rayFromTo :: ℝ3 -> ℝ3 -> Ray
 rayFromTo p1 p2 = Ray p1 (normalized $ p2 ^-^ p1)
 
@@ -91,19 +98,16 @@ rayBounds ray box =
         (lower, upper)
 
 -- Intersection
-
-
 intersection :: Ray -> ((ℝ,ℝ), ℝ) -> ℝ -> Obj3 -> Maybe ℝ3
 intersection r@(Ray p v) ((a, aval),b) res obj =
     let
-        step = 
-            if      aval/(4::ℝ) > res then res
-            else if aval/(2::ℝ) > res then res/(2 :: ℝ)
-            else                           res/(10 :: ℝ)
+        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 +115,18 @@ intersection r@(Ray p v) ((a, aval),b) res obj =
     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' :: Int -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ
+refine' :: ℕ -> ℝ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,13 +141,12 @@ intersects a b c d = case intersection a b c d of
     Just _  -> True
 
 -- Trace
-
 traceRay :: Ray -> ℝ -> (ℝ3, ℝ3) -> Scene -> Color
 traceRay ray@(Ray cameraP cameraV) step box (Scene obj objColor lights defaultColor) =
     let
         (a,b) = rayBounds ray box
     in case intersection ray ((a, obj (cameraP ^+^ a*^cameraV)), b) step obj of
-        Just p  -> flip colorMult objColor $ floor (sum $ [0.2] ++ do
+        Just p  -> flip colorMult objColor $ floor (sum $ 0.2 : do
             Light lightPos lightIntensity <- lights
             let
                 ray'@(Ray _ v) = rayFromTo p lightPos
@@ -154,19 +157,19 @@ traceRay ray@(Ray cameraP cameraV) step box (Scene obj objColor lights defaultCo
                 dirDeriv :: ℝ3 -> ℝ
                 dirDeriv v'' = (obj (p ^+^ step*^v'') ^-^ pval)/step
                 deriv = (dirDeriv (1,0,0), dirDeriv (0,1,0), dirDeriv (0,0,1))
-                normal = normalized $ deriv
-                unitV = normalized $ v'
-                proj :: forall v. InnerSpace v => v -> v -> v
+                normal = normalized deriv
+                unitV = normalized 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 = 
+                illumination = max 0 (normal ⋅ unitV) * lightIntensity * (25 /dist)
+                rV =
                     let
                         normalComponent = proj v' normal
                         parComponent    = v' - normalComponent
                     in
-                        normalComponent - parComponent    
-            return $ illumination*(3 + 0.3*(abs $ rV ⋅ cameraV)*(abs $ rV ⋅ cameraV))
+                        normalComponent - parComponent
+            return $ illumination*(3 + 0.3*abs(rV ⋅ cameraV)*abs(rV ⋅ cameraV))
             )
         Nothing   -> defaultColor
 

Graphics/Implicit/Export/Render.hs

@@ -8,11 +8,12 @@
 -- Allow us to use the tearser parallel list comprehension syntax, to avoid having to call zip in the complicated comprehensions below.
 {-# LANGUAGE ParallelListComp #-}
 
-module Graphics.Implicit.Export.Render where
+-- export getContour and getMesh, which returns the edge of a 2D object, or the surface of a 3D object, respectively.
+module Graphics.Implicit.Export.Render (getMesh, getContour) where
 
-import Prelude(Float, Bool, ceiling, ($), (/), fromIntegral, (+), (*), fromInteger, max, div, tail, map, concat, realToFrac, (==), (||), filter, not, reverse, (.), Integral, Eq, Integer, concatMap)
+import Prelude(ceiling, ($), fromIntegral, (+), (*), max, div, tail, map, concat, reverse, (.), concatMap)
 
-import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, Obj2, Obj3, TriangleMesh, Triangle, Polyline)
+import Graphics.Implicit.Definitions (ℝ, ℕ, ℝ2, ℝ3, TriangleMesh, Obj2, Obj3, Polyline(Polyline), (⋯/), both, allthree, fromℕtoℝ)
 
 import Data.VectorSpace ((^-^))
 
@@ -41,7 +42,7 @@ import Graphics.Implicit.Export.Render.HandleSquares (mergedSquareTris)
 
 -- Success: This is our mesh.
 
--- Each step is done in parallel using Control.Parallel.Strategies
+-- Each step on the Z axis is done in parallel using Control.Parallel.Strategies
 import Control.Parallel.Strategies (using, rdeepseq, parBuffer)
 
 import Control.DeepSeq (NFData)
@@ -66,38 +67,36 @@ import Control.DeepSeq (NFData)
 -- For the 2D case, we need one last thing, cleanLoopsFromSegs:
 import Graphics.Implicit.Export.Render.HandlePolylines (cleanLoopsFromSegs)
 
+-- FIXME: res should be ℝ3, not ℝ.
 getMesh :: ℝ3 -> ℝ3 -> ℝ -> Obj3 -> TriangleMesh
 getMesh p1@(x1,y1,z1) p2 res obj =
     let
         -- How much space are we rendering?
-        (dx,dy,dz) = p2 ^-^ p1
+        d = p2 ^-^ p1
 
         -- How many steps will we take on each axis?
-        nx :: Integral a => a
-        nx = ceiling $ dx / res
-        ny :: Integral a => a
-        ny = ceiling $ dy / res
-        nz :: Integral a => a
-        nz = ceiling $ dz / res
+        nx :: ℕ
+        ny :: ℕ
+        nz :: ℕ
+        (nx,ny,nz) = ceiling `allthree` ( d ⋯/ (res,res,res))
 
         -- How big are the steps?
-        rx = dx / fromInteger nx
-        ry = dy / fromInteger ny
-        rz = dz / fromInteger nz
+        (rx,ry,rz) = d ⋯/ (fromℕtoℝ `allthree` (nx,ny,nz))
 
         -- The positions we're rendering.
-        pXs = [ x1 + rx*n | n <- [0.. fromInteger nx] ]
-        pYs = [ y1 + ry*n | n <- [0.. fromInteger ny] ]
-        pZs = [ z1 + rz*n | n <- [0.. fromInteger nz] ]
+        pXs = [ x1 + rx*n | n <- [0.. fromℕtoℝ nx] ]
+        pYs = [ y1 + ry*n | n <- [0.. fromℕtoℝ ny] ]
+        pZs = [ z1 + rz*n | n <- [0.. fromℕtoℝ nz] ]
 
-        par3DList :: forall t. NFData t => Integer -> Integer -> Integer -> ((Integer -> ℝ) -> Integer -> (Integer -> ℝ) -> Integer -> (Integer -> ℝ) -> Integer -> t) -> [[[t]]]
+        -- | Perform a function on every point in a 3D grid.
+        par3DList :: forall t. NFData t => ℕ -> ℕ -> ℕ -> ((ℕ -> ℝ) -> ℕ -> (ℕ -> ℝ) -> ℕ -> (ℕ -> ℝ) -> ℕ -> t) -> [[[t]]]
         par3DList lenx leny lenz f =
             [[[f
-                (\n -> x1 + rx*fromInteger (mx+n)) mx
-                (\n -> y1 + ry*fromInteger (my+n)) my
-                (\n -> z1 + rz*fromInteger (mz+n)) mz
+                (\n -> x1 + rx*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 . fromInteger $ div lenz 32) rdeepseq)
+                `using` parBuffer (max 1 . fromIntegral $ div lenz 32) rdeepseq
 
         -- Evaluate obj to avoid waste in mids, segs, later.
         objV = par3DList (nx+2) (ny+2) (nz+2) $ \x _ y _ z _ -> obj (x 0, y 0, z 0)
@@ -108,25 +107,25 @@ getMesh p1@(x1,y1,z1) p2 res obj =
                  | x0 <- pXs |                  objX0Y0Z0 <- objY0Z0 | objX0Y0Z1 <- objY0Z1
                 ]| y0 <- pYs |                  objY0Z0 <- objZ0 | objY0Z1 <- objZ1
                 ]| z0 <- pZs | z1' <- tail pZs | objZ0   <- objV  | objZ1   <- tail objV
-                ] `using` (parBuffer (max 1 . fromInteger $ div nz 32) rdeepseq)
+                ] `using` parBuffer (max 1 . fromIntegral $ div nz 32) rdeepseq
 
         midsY = [[[
                  interpolate (y0, objX0Y0Z0) (y1', objX0Y1Z0) (appAC obj x0 z0) res
                  | x0 <- pXs |                  objX0Y0Z0 <- objY0Z0 | objX0Y1Z0 <- objY1Z0
                 ]| y0 <- pYs | y1' <- tail pYs | objY0Z0 <- objZ0 | objY1Z0 <- tail objZ0
                 ]| z0 <- pZs |                  objZ0   <- objV
-                ] `using` (parBuffer (max 1 $ fromInteger $ div nz 32) rdeepseq)
+                ] `using` parBuffer (max 1 $ fromIntegral $ div ny 32) rdeepseq
 
         midsX = [[[
                  interpolate (x0, objX0Y0Z0) (x1', objX1Y0Z0) (appBC obj y0 z0) res
                  | x0 <- pXs | x1' <- tail pXs | objX0Y0Z0 <- objY0Z0 | objX1Y0Z0 <- tail objY0Z0
                 ]| y0 <- pYs |                  objY0Z0 <- objZ0
                 ]| z0 <- pZs |                  objZ0   <- objV
-                ] `using` (parBuffer (max 1 $ fromInteger $ div nz 32) rdeepseq)
+                ] `using` parBuffer (max 1 $ fromIntegral $ div nx 32) rdeepseq
 
         -- Calculate segments for each side
         segsZ = [[[
-            map2  (inj3 z0) $ getSegs (x0,y0) (x1',y1') (obj **$ z0)
+            map (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''
@@ -135,10 +134,10 @@ getMesh p1@(x1,y1,z1) p2 res obj =
              |objY0Z0 <- objZ0 | objY1Z0 <- tail objZ0
             ]|z0<-pZs             |mX'  <-midsX|                mY'  <-midsY
              |objZ0 <- objV
-            ] `using` (parBuffer (max 1 $ fromInteger $ div nz 32) rdeepseq)
+            ] `using` parBuffer (max 1 $ fromIntegral $ div nz 32) rdeepseq
 
         segsY = [[[
-            map2  (inj2 y0) $ getSegs (x0,z0) (x1',z1') (obj *$* y0)
+            map (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''
@@ -147,10 +146,10 @@ getMesh p1@(x1,y1,z1) p2 res obj =
              |objY0Z0 <- objZ0 | objY0Z1 <- objZ1
             ]|z0<-pZs|z1'<-tail pZs|mB'  <-midsX|mBT  <-tail midsX|mA'  <-midsZ
              |objZ0 <- objV | objZ1 <- tail objV
-            ] `using` (parBuffer (max 1 $ fromInteger $ div nz 32) rdeepseq)
+            ] `using` parBuffer (max 1 $ fromIntegral $ div ny 32) rdeepseq
 
         segsX = [[[
-            map2  (inj1 x0) $ getSegs (y0,z0) (y1',z1') (obj $** x0)
+            map (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
@@ -159,7 +158,7 @@ getMesh p1@(x1,y1,z1) p2 res obj =
              |objY0Z0  <-objZ0  |objY1Z0  <-tail objZ0  |objY0Z1  <-objZ1  |objY1Z1  <-tail objZ1
             ]|z0<-pZs|z1'<-tail pZs|mB'  <-midsY|mBT  <-tail midsY|mA'  <-midsZ
              |objZ0 <- objV | objZ1 <- tail objV
-            ]  `using` (parBuffer (max 1 $ fromInteger $ div nz 32) rdeepseq)
+            ]  `using` parBuffer (max 1 $ fromIntegral $ div nx 32) rdeepseq
 
         -- (3) & (4) : get and tesselate loops
         sqTris = [[[
@@ -183,49 +182,38 @@ getMesh p1@(x1,y1,z1) p2 res obj =
             ]| segZ'  <- segsZ | segZT  <- tail segsZ
              | segY' <- segsY
              | segX' <- segsX
-            ]   `using` (parBuffer (max 1 $ fromInteger $ div nz 32) rdeepseq)
+            ]   `using` parBuffer (max 1 $ fromIntegral $ div nz 32) rdeepseq
 
-    in cleanupTris $ mergedSquareTris $ concat $ concat $ concat sqTris -- (5) merge squares, etc
-
--- 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
+    in
+      -- (5) merge squares, etc
+      mergedSquareTris . concat . concat $ concat sqTris
 
+-- getContour gets a polyline describing the edge of a 2D object.
 getContour :: ℝ2 -> ℝ2 -> ℝ -> Obj2 -> [Polyline]
 getContour p1@(x1, y1) p2 res obj =
     let
-        (dx,dy) = p2 ^-^ p1
+        -- the size of the region we're being asked to search.
+        d = p2 ^-^ p1
 
         -- How many steps will we take on each axis?
-        nx :: Integral a => a
-        nx = ceiling $ dx / res
-        ny :: Integral a => a
-        ny = ceiling $ dy / res
+        nx :: ℕ
+        ny :: ℕ
+        (nx,ny) = ceiling `both` (d ⋯/ (res,res))
 
-        rx = dx/fromInteger nx
-        ry = dy/fromInteger ny
+        -- How big are the steps?
+        (rx,ry) = d ⋯/ (fromℕtoℝ `both` (nx,ny))
 
-        pYs = [ y1 + ry*n | n <- [0.. fromInteger ny] ]
-        pXs = [ x1 + rx*n | n <- [0.. fromInteger nx] ]
+        -- the points inside of the region.
+        pYs = [ y1 + ry*fromℕtoℝ p | p <- [0.. ny] ]
+        pXs = [ x1 + rx*fromℕtoℝ p | p <- [0.. nx] ]
 
-        par2DList :: forall t. NFData t => Integer -> Integer -> ((Integer -> ℝ) -> Integer -> (Integer -> ℝ) -> Integer -> t) -> [[t]]
+        par2DList :: forall t. NFData t => ℕ -> ℕ -> ((ℕ -> ℝ) -> ℕ -> (ℕ -> ℝ) -> ℕ -> t) -> [[t]]
         par2DList lenx leny f =
             [[ f
-                (\n -> x1 + rx*fromIntegral (mx+n)) mx
-                (\n -> y1 + ry*fromIntegral (my+n)) my
+                (\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 $ fromInteger $ div leny 32) rdeepseq)
+                `using` parBuffer (max 1 . fromIntegral $ div leny 32) rdeepseq
 
 
         -- Evaluate obj to avoid waste in mids, segs, later.
@@ -238,13 +226,13 @@ getContour p1@(x1, y1) p2 res obj =
                  interpolate (y0, objX0Y0) (y1', objX0Y1) (obj $* x0) res
                  | x0 <- pXs |                  objX0Y0 <- objY0   | objX0Y1 <- objY1
                 ]| y0 <- pYs | y1' <- tail pYs | objY0   <- objV    | objY1   <- tail objV
-                ] `using` (parBuffer (max 1 $ fromInteger $ div ny 32) rdeepseq)
+                ] `using` parBuffer (max 1 . fromIntegral $ div ny 32) rdeepseq
 
         midsX = [[
                  interpolate (x0, objX0Y0) (x1', objX1Y0) (obj *$ y0) res
                  | x0 <- pXs | x1' <- tail pXs | objX0Y0 <- objY0 | objX1Y0 <- tail objY0
                 ]| y0 <- pYs |                  objY0   <- objV
-                ] `using` (parBuffer (max 1 $ fromInteger $ div ny 32) rdeepseq)
+                ] `using` parBuffer (max 1 . fromIntegral $ div nx 32) rdeepseq
 
         -- Calculate segments for each side
 
@@ -256,21 +244,25 @@ getContour p1@(x1, y1) p2 res obj =
              |objX0Y0<-objY0|objX1Y0<-tail objY0|objX0Y1<-objY1|objX1Y1<-tail objY1
             ]|y0<-pYs|y1'<-tail pYs|mX'' <-midsX|mX'T <-tail midsX|mY'' <-midsY
              |objY0 <- objV  | objY1 <- tail objV
-            ] `using` (parBuffer (max 1 $ fromInteger $ div ny 32) rdeepseq)
-
-    in cleanLoopsFromSegs $ concat $ concat $ segs -- (5) merge squares, etc
-
-
+            ] `using` parBuffer (max 1 . fromIntegral $ div ny 32) rdeepseq
 
+    in
+      cleanLoopsFromSegs . concat $ concat segs -- (5) merge squares, etc
 
 -- utility functions
 
-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) = map (prepend a) xs
+prepend :: ℝ -> ℝ2 -> ℝ3
+prepend a (b,c) = (a,b,c)
+injY :: ℝ -> Polyline -> [ℝ3]
+injY a (Polyline xs) = map (insert a) xs
+insert :: ℝ -> ℝ2 -> ℝ3
+insert b (a,c) = (a,b,c)
+injZ :: ℝ -> Polyline -> [ℝ3]
+injZ a (Polyline xs) = map (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
 infixr 0 $**
@@ -291,16 +283,12 @@ 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)
+appAB f a b c = f (a,b,c)
 appBC :: forall t t1 t2 t3. ((t1, t2, t3) -> t) -> t2 -> t3 -> t1 -> t
-appBC f b c = \a -> f (a,b,c)
+appBC f b c a = f (a,b,c)
 appAC :: forall t t1 t2 t3. ((t1, t2, t3) -> t) -> t1 -> t3 -> t2 -> t
-appAC f a c = \b -> f (a,b,c)
+appAC f a c b = f (a,b,c)
 
-map2 :: forall a b. (a -> b) -> [[a]] -> [[b]]
-map2 f = map (map f)
-map2R :: forall a a1. (a1 -> a) -> [[a1]] -> [[a]]
-map2R f = map (reverse . map f)
 mapR :: forall a. [[a]] -> [[a]]
 mapR = map reverse
 

Graphics/Implicit/Export/Render/Definitions.hs

@@ -1,25 +1,18 @@
 -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
 -- Released under the GNU AGPLV3+, see LICENSE
 
+-- We want a type that can represent squares/quads and triangles.
 module Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq)) where
 
 import Prelude()
 
-import Graphics.Implicit.Definitions(ℝ, ℝ2, ℝ3, Triangle)
+import Graphics.Implicit.Definitions(ℝ, ℝ2, ℝ3, TriangleMesh)
 
 import Control.DeepSeq (NFData, rnf)
 
--- We want a format that can represent squares/quads and triangles.
--- So that we can merge squares and thereby reduces triangles.
-
--- Regarding Sq: Sq Basis@(b1,b2,b3) (Height on b3)
---                  (b1 pos 1, b2 pos 1) (b1 pos 2, b2 pos 2)
-
 data TriSquare =
       Sq (ℝ3,ℝ3,ℝ3) ℝ ℝ2 ℝ2
-    | Tris [Triangle]
-
--- For use with Parallel.Strategies later
+    | Tris TriangleMesh
 
 instance NFData TriSquare where
     rnf (Sq b z xS yS) = rnf (b,z,xS,yS)

Graphics/Implicit/Export/Render/GetLoops.hs

@@ -8,8 +8,9 @@
 module Graphics.Implicit.Export.Render.GetLoops (getLoops) where
 
 -- Explicitly include what we want from Prelude.
-import Prelude (Eq, head, last, tail, (==), Bool(False), filter, not, (.), null, error, (++))
+import Prelude (Eq, head, last, tail, (==), Bool(False), (.), null, error, (++))
 
+import Data.List (partition)
 -- The goal of getLoops is to extract loops from a list of segments.
 
 -- The input is a list of segments.
@@ -51,7 +52,7 @@ getLoops' [] [] = []
 getLoops' (x:xs) [] = getLoops' xs [x]
 
 -- A loop is finished if its start and end are the same.
--- In this case, we return it and empty the building loop.
+-- In this case, we return it and start searching for another loop.
 
 getLoops' segs workingLoop | head (head workingLoop) == last (last workingLoop) =
     workingLoop : getLoops' segs []
@@ -60,16 +61,14 @@ getLoops' segs workingLoop | head (head workingLoop) == last (last workingLoop)
 -- and stick one on if we find it.
 -- Otherwise... something is really screwed up.
 
--- FIXME: connects should be used with a singleton.
-
 getLoops' segs workingLoop =
     let
         presEnd :: forall c. [[c]] -> c
         presEnd = last . last
         connects (x:_) = x == presEnd workingLoop
         connects [] = False -- Handle the empty case.
-        possibleConts = filter connects segs
-        nonConts = filter (not . connects) segs
+        -- divide our set into sequences that connect, and sequences that don't.
+        (possibleConts,nonConts) = partition connects segs
         (next, unused) = if null possibleConts
             then error "unclosed loop in paths given"
             else (head possibleConts, tail possibleConts ++ nonConts)

Graphics/Implicit/Export/Render/GetSegs.hs

@@ -4,9 +4,9 @@
 
 module Graphics.Implicit.Export.Render.GetSegs (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)
 
@@ -73,17 +73,15 @@ getSegs p1 p2 obj (x1y1, x2y1, x1y2, x2y2) (midx1V,midx2V,midy1V,midy2V) =
         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.
 
-    in map (refine res obj) . filter (notPointLine) $ case (x1y2 <= 0, x2y2 <= 0,
-                                                            x1y1 <= 0, x2y1 <= 0) of
+    in map (refine res obj) . filter notPointLine $ case (x1y2 <= 0, x2y2 <= 0,
+                                                          x1y1 <= 0, x2y1 <= 0) of
 
         -- An important point here is orientation. If you imagine going along a
         -- generated segment, the interior should be on the left-hand side.
@@ -99,56 +97,56 @@ getSegs p1 p2 obj (x1y1, x2y1, x1y2, x2y2) (midx1V,midx2V,midy1V,midy2V) =
         -- Horizontal Cases
 
         (True,  True,
-         False, False) -> [[midx1, midx2]]
+         False, False) -> [Polyline [midx1, midx2]]
 
         (False, False,
-         True,  True)  -> [[midx2, midx1]]
+         True,  True)  -> [Polyline [midx2, midx1]]
 
         -- Vertical Cases
 
         (False, True,
-         False, True)  -> [[midy2, midy1]]
+         False, True)  -> [Polyline [midy2, midy1]]
 
         (True,  False,
-         True,  False) -> [[midy1, midy2]]
+         True,  False) -> [Polyline [midy1, midy2]]
 
         -- Corner Cases
 
         (True,  False,
-         False, False) -> [[midx1, midy2]]
+         False, False) -> [Polyline [midx1, midy2]]
 
         (False, True,
-         True,  True)  -> [[midy2, midx1]]
+         True,  True)  -> [Polyline [midy2, midx1]]
 
         (True,  True,
-         False, True)  -> [[midx1, midy1]]
+         False, True)  -> [Polyline [midx1, midy1]]
 
         (False, False,
-         True,  False) -> [[midy1, midx1]]
+         True,  False) -> [Polyline [midy1, midx1]]
 
         (True,  True,
-         True,  False) -> [[midy1, midx2]]
+         True,  False) -> [Polyline [midy1, midx2]]
 
         (False, False,
-         False, True)  -> [[midx2, midy1]]
+         False, True)  -> [Polyline [midx2, midy1]]
 
         (True,  False,
-         True,  True)  -> [[midx2, midy2]]
+         True,  True)  -> [Polyline [midx2, midy2]]
 
         (False, True,
-         False, False) -> [[midy2, midx2]]
+         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]]
+            then [Polyline [midx1, midy1], Polyline [midx2, midy2]]
+            else [Polyline [midx1, midy2], Polyline [midx2, midy1]]
 
         (False, True,
          True,  False) -> if c <= 0
-            then [[midy2, midx1], [midy1, midx2]]
-            else [[midy1, midx1], [midy2, midx2]]
+            then [Polyline [midy2, midx1], Polyline [midy1, midx2]]
+            else [Polyline [midy1, midx1], Polyline [midy2, midx2]]
 
 
 -- A convenience function, we don't actually care too much about

Graphics/Implicit/Export/Render/HandlePolylines.hs

@@ -7,9 +7,9 @@
 
 module Graphics.Implicit.Export.Render.HandlePolylines (cleanLoopsFromSegs, reducePolyline) where
 
-import Prelude(Bool(False), Maybe(Just, Nothing), map, (.), filter, (==), last, reverse, ($), (++), tail, (-), (/), abs, (<=), (||), (&&), (*), (>), not, null)
+import Prelude(Bool(True, False), Maybe(Just, Nothing), map, (.), filter, (==), last, reverse, ($), (++), (-), (/), abs, (<=), (||), (&&), (*), (>), otherwise)
 
-import Graphics.Implicit.Definitions (minℝ, Polyline, ℝ)
+import Graphics.Implicit.Definitions (minℝ, Polyline(Polyline))
 
 cleanLoopsFromSegs :: [Polyline] -> [Polyline]
 cleanLoopsFromSegs =
@@ -17,34 +17,45 @@ cleanLoopsFromSegs =
     . joinSegs
     . filter polylineNotNull
 
+-- | Join polylines that connect.
 joinSegs :: [Polyline] -> [Polyline]
 joinSegs [] = []
-joinSegs (present:remaining) =
+joinSegs (Polyline 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 :: [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
 
-reducePolyline :: [(ℝ, ℝ)] -> [(ℝ, ℝ)]
-reducePolyline ((x1,y1):(x2,y2):(x3,y3):others) =
-    if (x1,y1) == (x2,y2) then reducePolyline ((x2,y2):(x3,y3):others) else
-    if abs ( (y2-y1)/(x2-x1) - (y3-y1)/(x3-x1) ) <= minℝ
-       || ( (x2-x1) == 0 && (x3-x1) == 0 && (y2-y1)*(y3-y1) > 0)
-    then reducePolyline ((x1,y1):(x3,y3):others)
-    else (x1,y1) : reducePolyline ((x2,y2):(x3,y3):others)
-reducePolyline ((x1,y1):(x2,y2):others) =
-    if (x1,y1) == (x2,y2) then reducePolyline ((x2,y2):others) else (x1,y1):(x2,y2):others
+-- | Simplify and sort a polyline.
+reducePolyline :: Polyline -> Polyline
+reducePolyline (Polyline ((x1,y1):(x2,y2):(x3,y3):others))
+    -- Remove 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 (Polyline ((x1,y1):(x3,y3):others))
+    | otherwise = Polyline ((x1,y1) : (points $ reducePolyline (Polyline ((x2,y2):(x3,y3):others))))
+  where
+    points (Polyline pts) = pts
+-- | remove 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 = l
 
-polylineNotNull :: [a] -> Bool
-polylineNotNull (_:l) = not (null l)
-polylineNotNull [] = False
+-- ensure that polylines are not empty.
+polylineNotNull :: Polyline -> Bool
+polylineNotNull (Polyline (_:_:_)) = True
+polylineNotNull (Polyline [_]) = True
+polylineNotNull (Polyline []) = False
 
 {-cleanLoopsFromSegs =
     connectPolys

Graphics/Implicit/Export/Render/HandleSquares.hs

@@ -4,9 +4,9 @@
 
 module Graphics.Implicit.Export.Render.HandleSquares (mergedSquareTris) where
 
-import Prelude(concatMap, (++))
+import Prelude(concatMap, (++), ($))
 
-import Graphics.Implicit.Definitions (Triangle)
+import Graphics.Implicit.Definitions (TriangleMesh(TriangleMesh), Triangle(Triangle))
 import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq))
 import Data.VectorSpace ((^*), (*^), (^+^))
 
@@ -57,16 +57,21 @@ import Data.VectorSpace ((^*), (*^), (^+^))
 
 -}
 
-mergedSquareTris :: [TriSquare] -> [Triangle]
+mergedSquareTris :: [TriSquare] -> TriangleMesh
 mergedSquareTris sqTris =
     let
         -- We don't need to do any work on triangles. They'll just be part of
         -- the list of triangles we give back. So, the triangles coming from
         -- triangles...
-        triTriangles = [tri | Tris tris <- sqTris, tri <- tris ]
+        triTriangles :: [Triangle]
+        triTriangles = [tri | Tris tris <- sqTris, tri <- unmesh tris ]
         --concat $ map (\(Tris a) -> a) $ filter isTris sqTris
         -- We actually want to work on the quads, so we find those
-        squaresFromTris = [ (Sq x y z q) | Sq x y z q <- sqTris ]
+        squaresFromTris :: [TriSquare]
+        squaresFromTris = [ Sq x y z q | Sq x y z q <- sqTris ]
+
+        unmesh (TriangleMesh m) = m
+
 {-
         -- Collect ones that are on the same plane.
         planeAligned = groupWith (\(Sq basis z _ _) -> (basis,z)) squares
@@ -85,7 +90,7 @@ mergedSquareTris sqTris =
         -- 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 ++ concatMap squareToTri squaresFromTris
 
 -- And now for a bunch of helper functions that do the heavy lifting...
 
@@ -125,7 +130,7 @@ joinYaligned quads@((Sq b z _ yS):_) =
 joinYaligned [] = []
 -}
 
--- Reconstruct a triangle
+-- Deconstruct a square into two triangles.
 squareToTri :: TriSquare -> [Triangle]
 squareToTri (Sq (b1,b2,b3) z (x1,x2) (y1,y2)) =
     let
@@ -137,8 +142,9 @@ squareToTri (Sq (b1,b2,b3) z (x1,x2) (y1,y2)) =
         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

@@ -7,9 +7,9 @@
 
 module Graphics.Implicit.Export.Render.Interpolate (interpolate) where
 
-import Prelude(Integer, (*), (>), (<), (/=), (+), (-), (/), (==), (&&), abs)
+import Prelude((*), (>), (<), (/=), (+), (-), (/), (==), (&&), abs)
 
-import Graphics.Implicit.Definitions (ℝ, ℝ2)
+import Graphics.Implicit.Definitions (ℝ, ℕ, ℝ2)
 
 -- Consider a function f(x):
 
@@ -43,6 +43,8 @@ import Graphics.Implicit.Definitions (ℝ, ℝ2)
 -- If it doesn't cross zero, we don't actually care what answer we give,
 -- just that it's cheap.
 
+-- FIXME: accept resolution on multiple axises.
+
 interpolate :: ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ -> ℝ
 interpolate (a,aval) (_,bval) _ _ | aval*bval > 0 = a
 
@@ -89,38 +91,38 @@ interpolate _ (b, 0) _ _  = b
         -- The best case is that it crosses between a and a'
         if aval*a'val < 0
         then
-            interpolate_bin 0 (a,aval) (a',a'val) f
+            interpolateBin 0 (a,aval) (a',a'val) f
         -- Or between b' and b
         else if bval*b'val < 0
-        then interpolate_bin 0 (b',b'val) (b,bval) f
+        then interpolateBin 0 (b',b'val) (b,bval) f
         -- But in the worst case, we get to shrink to (a',b') :)
-        else interpolate_bin 0 (a',a'val) (b',b'val) f
+        else interpolateBin 0 (a',a'val) (b',b'val) f
     -- Otherwise, we use our friend, linear interpolation!
     else
         -- again...
         -- The best case is that it crosses between a and a'
         if aval*a'val < 0
         then
-            interpolate_lin 0 (a,aval) (a',a'val) f
+            interpolateLin 0 (a,aval) (a',a'val) f
         -- Or between b' and b
         else if bval*b'val < 0
-        then interpolate_lin 0 (b',b'val) (b,bval) f
+        then interpolateLin 0 (b',b'val) (b,bval) f
         -- But in the worst case, we get to shrink to (a',b') :)
-        else interpolate_lin 0 (a',a'val) (b',b'val) f
+        else interpolateLin 0 (a',a'val) (b',b'val) f
 -}
 
 interpolate (a,aval) (b,bval) f _ =
-    -- Make sure aval > bval, then pass to interpolate_lin
+    -- Make sure aval > bval, then pass to interpolateLin
     if aval > bval
-    then interpolate_lin 0 (a,aval) (b,bval) f
-    else interpolate_lin 0 (b,bval) (a,aval) f
+    then interpolateLin 0 (a,aval) (b,bval) f
+    else interpolateLin 0 (b,bval) (a,aval) f
 
 -- Yay, linear interpolation!
 
 -- Try the answer linear interpolation gives us...
 -- (n is to cut us off if recursion goes too deep)
-interpolate_lin :: Integer -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ
-interpolate_lin n (a, aval) (b, bval) obj | aval /= bval=
+interpolateLin :: ℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ
+interpolateLin n (a, aval) (b, bval) obj | aval /= bval=
     let
         -- Interpolate and evaluate
         mid :: ℝ
@@ -144,32 +146,32 @@ interpolate_lin n (a, aval) (b, bval) obj | aval /= bval=
     -- to zero than the previous one.
     in if improveRatio < 0.3 && n < 4
     -- And we continue on.
-    then interpolate_lin (n+1) (a', a'val) (b', b'val) obj
+    then interpolateLin (n+1) (a', a'val) (b', b'val) obj
     -- But if not, we switch to binary interpolate, which is
     -- immune to this problem
-    else interpolate_bin (n+1) (a', a'val) (b', b'val) obj
+    else interpolateBin (n+1) (a', a'val) (b', b'val) obj
 
 -- And a fallback:
-interpolate_lin _ (a, _) _ _ = a
+interpolateLin _ (a, _) _ _ = a
 
 -- Now for binary searching!
-interpolate_bin :: Integer -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ
+interpolateBin :: ℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ
 
 -- The termination case:
 
-interpolate_bin 5 (a,aval) (b,bval) _ =
+interpolateBin 5 (a,aval) (b,bval) _ =
     if abs aval < abs bval
     then a
     else b
 
 -- Otherwise, have fun with mid!
 
-interpolate_bin n (a,aval) (b,bval) f =
+interpolateBin n (a,aval) (b,bval) f =
     let
         mid :: ℝ
         mid = (a+b)/2
         midval = f mid
     in if midval > 0
-    then interpolate_bin (n+1) (mid,midval) (b,bval) f
-    else interpolate_bin (n+1) (a,aval) (mid,midval) f
+    then interpolateBin (n+1) (mid,midval) (b,bval) f
+    else interpolateBin (n+1) (a,aval) (mid,midval) f
 

Graphics/Implicit/Export/Render/RefineSegs.hs

@@ -2,11 +2,12 @@
 -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com)
 -- Released under the GNU AGPLV3+, see LICENSE
 
+-- export one function, which refines polylines.
 module Graphics.Implicit.Export.Render.RefineSegs (refine) where
 
-import Prelude(Int, (<), (/), (++), (*), ($), (&&), (-), (+), (.), (>), abs, tail, sqrt, (<=))
+import Prelude((<), (/), (++), (*), ($), (&&), (-), (+), (.), (>), abs, sqrt, (<=))
 
-import Graphics.Implicit.Definitions (ℝ, ℝ2, minℝ, Obj2, (⋅))
+import Graphics.Implicit.Definitions (ℝ, ℝ2, Polyline(Polyline), minℝ, ℕ, Obj2, (⋅))
 import Graphics.Implicit.Export.Util (centroid)
 
 import Data.VectorSpace (normalized, magnitude, (^-^), (^*), (^+^))
@@ -16,64 +17,73 @@ import Data.VectorSpace (normalized, magnitude, (^-^), (^*), (^+^))
 
 -- We break this into two steps: detail and then simplify.
 
-refine :: ℝ -> Obj2 -> [ℝ2] -> [ℝ2]
+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'
 
 -- 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 :: Int -> ℝ -> (ℝ2 -> ℝ) -> [ℝ2] -> [ℝ2]
-detail n res obj [p1, p2] | n < 2 =
+-- FIXME: all of the magic numbers.
+-- | detail adds new points to a polyline to add more detail.
+detail :: ℕ -> ℝ -> (ℝ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]
+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]

Graphics/Implicit/Export/Render/TesselateLoops.hs

@@ -4,18 +4,25 @@
 
 module Graphics.Implicit.Export.Render.TesselateLoops (tesselateLoop) where
 
-import Prelude(Int, return, ($), length, (==), zip, init, tail, reverse, (<), (/), null, foldl1, (++), head, (*), abs, (>), (&&), (+), concatMap)
-import Graphics.Implicit.Definitions (ℝ, Obj3, ℝ3, Triangle, (⋅))
+import Prelude(return, ($), length, (==), zip, init, tail, reverse, (<), (/), null, foldl1, (++), head, (*), abs, (>), (&&), (+), concatMap)
+
+import Graphics.Implicit.Definitions (ℝ, ℕ, Obj3, ℝ3, TriangleMesh(TriangleMesh), (⋅), Triangle(Triangle))
+
 import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq))
+
 import Graphics.Implicit.Export.Util (centroid)
+
 import Data.VectorSpace (normalized, (^-^), (^+^), magnitude, (^/), (^*))
+
+import Data.List (genericLength)
+
 import Data.Cross (cross3)
 
 tesselateLoop :: ℝ -> Obj3 -> [[ℝ3]] -> [TriSquare]
 
 tesselateLoop _ _ [] = []
 
-tesselateLoop _ _ [[a,b],[_,c],[_,_]] = return $ Tris [(a,b,c)]
+tesselateLoop _ _ [[a,b],[_,c],[_,_]] = [Tris $ TriangleMesh [Triangle (a,b,c)]]
 
 
 {-
@@ -27,12 +34,12 @@ tesselateLoop _ _ [[a,b],[_,c],[_,_]] = return $ Tris [(a,b,c)]
 -}
 
 tesselateLoop res obj [[_,_], as@(_:_:_:_),[_,_], bs@(_:_:_:_)] | length as == length bs =
-    concatMap (tesselateLoop res obj) $
+    concatMap (tesselateLoop res obj)
         [[[a1,b1],[b1,b2],[b2,a2],[a2,a1]] | ((a1,b1),(a2,b2)) <- zip (init pairs) (tail pairs)]
             where pairs = zip (reverse as) bs
 
 tesselateLoop res obj [as@(_:_:_:_),[_,_], bs@(_:_:_:_), [_,_] ] | length as == length bs =
-    concatMap (tesselateLoop res obj) $
+    concatMap (tesselateLoop res obj)
         [[[a1,b1],[b1,b2],[b2,a2],[a2,a1]] | ((a1,b1),(a2,b2)) <- zip (init pairs) (tail pairs)]
             where pairs = zip (reverse as) bs
 
@@ -58,11 +65,12 @@ tesselateLoop _ _ [[a,_],[b,_],[c,_],[d,_]] | centroid [a,c] == centroid [b,d] =
 -}
 
 tesselateLoop res obj [[a,_],[b,_],[c,_],[d,_]] | obj (centroid [a,c]) < res/30 =
-    return $ Tris $ [(a,b,c),(a,c,d)]
+    return $ 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 = return $ Tris $ TriangleMesh $
     let
         path' = concatMap init pathSides
         (early_tris,path) = shrinkLoop 0 path' res obj
@@ -71,7 +79,7 @@ tesselateLoop res obj pathSides = return $ Tris $
     else let
         mid@(_,_,_) = centroid path
         midval = obj mid
-        preNormal = foldl1 (^+^) $
+        preNormal = foldl1 (^+^)
             [ a `cross3` b | (a,b) <- zip path (tail path ++ [head path]) ]
         preNormalNorm = magnitude preNormal
         normal = preNormal ^/ preNormalNorm
@@ -79,24 +87,24 @@ tesselateLoop res obj pathSides = return $ Tris $
         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 :: Int -> [ℝ3] -> ℝ -> Obj3 -> ([Triangle], [ℝ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 =
+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
 

Graphics/Implicit/Export/Symbolic/CoerceSymbolic2.hs

@@ -2,7 +2,7 @@
 -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com)
 -- Released under the GNU AGPLV3+, see LICENSE
 
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
 
 module Graphics.Implicit.Export.Symbolic.CoerceSymbolic2 (coerceSymbolic2) where
 

Graphics/Implicit/Export/Symbolic/CoerceSymbolic3.hs

@@ -2,7 +2,7 @@
 -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com)
 -- Released under the GNU AGPLV3+, see LICENSE
 
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
 
 -- We just want to export the instance...
 module Graphics.Implicit.Export.Symbolic.CoerceSymbolic3 (coerceSymbolic3) where

Graphics/Implicit/Export/Symbolic/Rebound2.hs

@@ -16,4 +16,4 @@ rebound2 (obj, (a,b)) =
         d :: ℝ2
         d = (b ^-^ a) ^/ 10
     in
-        (obj, ((a ^-^ d), (b ^+^ d)))
+        (obj, (a ^-^ d, b ^+^ d))

Graphics/Implicit/Export/Symbolic/Rebound3.hs

@@ -10,11 +10,14 @@ 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
         d :: ℝ3
         d = (b ^-^ a) ^/ 10
     in
-        (obj, ((a ^-^ d), (b ^+^ d)))
+        (obj, (a ^-^ d, b ^+^ d))
 

Graphics/Implicit/Export/SymbolicFormats.hs

@@ -8,27 +8,27 @@
 -- 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(Maybe(Just, Nothing), Either(Left), ($), (.), (*), map, ($!), (-), (/), pi, error, (+), (==), take, floor)
 
 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 Control.Monad.Reader (Reader, runReader, return, fmap, sequence, ask)
 
-import Data.List (intersperse)
+import Data.List (intersperse, (++))
+import Data.Function (fix)
 
-scad2 :: ℝ -> SymbolicObj2 -> Text 
+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 [obj] = fmap ((name <> buildArgs cs args) <>) obj
@@ -38,7 +38,7 @@ callToken cs name args objs  = do
 
 buildArgs :: (Text, Text) -> [Builder] -> Builder
 buildArgs _ [] = "()"
-buildArgs (c1, c2) args = "(" <> (fromLazyText c1) <> mconcat (intersperse "," args) <> (fromLazyText c2) <> ")"
+buildArgs (c1, c2) args = "(" <> fromLazyText c1 <> mconcat (intersperse "," args) <> fromLazyText c2 <> ")"
 
 call :: Builder -> [Builder] -> [Reader a Builder] -> Reader a Builder
 call = callToken ("[", "]")
@@ -46,7 +46,7 @@ call = callToken ("[", "]")
 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] [
@@ -55,7 +55,7 @@ buildS3 (Rect3R r (x1,y1,z1) (x2,y2,z2)) | r == 0 = call "translate" [bf x1, bf
 
 buildS3 (Sphere r) = callNaked "sphere" ["r = " <> bf r] []
 
-buildS3 (Cylinder h r1 r2) = call "cylinder" [
+buildS3 (Cylinder h r1 r2) = callNaked "cylinder" [
                               "r1 = " <> bf r1
                              ,"r2 = " <> bf r2
                              , bf h
@@ -75,8 +75,7 @@ buildS3 (Scale3 (x,y,z) obj) = call "scale" [bf x, bf y, bf z] [buildS3 obj]
 
 buildS3 (Rotate3 (x,y,z) obj) = call "rotate" [bf (rad2deg x), bf (rad2deg y), bf (rad2deg z)] [buildS3 obj]
 
--- FIXME: where is Rotate3V?
-buildS3 (Rotate3V _ _ _) = error "Rotate3V not implemented."
+buildS3  Rotate3V{} = error "Rotate3V not implemented."
 
 buildS3 (Outset3 r obj) | r == 0 = call "outset" [] [buildS3 obj]
 
@@ -94,23 +93,23 @@ buildS3 (ExtrudeRM r (Just twist) Nothing Nothing obj (Left height)) | r == 0 =
              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?
 
-buildS3(Rect3R _ _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
+buildS3 Rect3R{} = error "cannot provide roundness when exporting openscad; unsupported in target format."
 buildS3(UnionR3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
 buildS3(IntersectR3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
 buildS3(DifferenceR3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
 buildS3(Outset3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
 buildS3(Shell3 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
-buildS3(ExtrudeR _ _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
-buildS3(ExtrudeRotateR _ _ _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
-buildS3(ExtrudeRM _ _ _ _ _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
+buildS3 ExtrudeR{} = error "cannot provide roundness when exporting openscad; unsupported in target format."
+buildS3 ExtrudeRotateR {} = error "cannot provide roundness when exporting openscad; unsupported in target format."
+buildS3 ExtrudeRM{} = error "cannot provide roundness when exporting openscad; unsupported in target format."
 buildS3(EmbedBoxedObj3 _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
-buildS3(RotateExtrude _ _ _ _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
+buildS3 RotateExtrude{} = error "cannot provide roundness when exporting openscad; unsupported in target format."
 buildS3(ExtrudeOnEdgeOf _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
 
 -- Now the 2D objects/transforms.
@@ -126,7 +125,7 @@ buildS2 (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) <> "]"
 
-buildS2 (Complement2 obj) = call "complement" [] $ [buildS2 obj]
+buildS2 (Complement2 obj) = call "complement" [] [buildS2 obj]
 
 buildS2 (UnionR2 r objs) | r == 0 = call "union" [] $ map buildS2 objs
 
@@ -134,18 +133,18 @@ buildS2 (DifferenceR2 r objs) | r == 0 = call "difference" [] $ map buildS2 objs
 
 buildS2 (IntersectR2 r objs) | r == 0 = call "intersection" [] $ map buildS2 objs
 
-buildS2 (Translate2 (x,y) obj) = call "translate" [bf x, bf y] $ [buildS2 obj]
+buildS2 (Translate2 (x,y) obj) = call "translate" [bf x, bf y] [buildS2 obj]
 
-buildS2 (Scale2 (x,y) obj)     = call "scale" [bf x, bf y] $ [buildS2 obj]
+buildS2 (Scale2 (x,y) obj)     = call "scale" [bf x, bf y] [buildS2 obj]
 
-buildS2 (Rotate2 (r) obj)     = call "rotate" [bf (rad2deg r)] $ [buildS2 obj]
+buildS2 (Rotate2 r obj)     = call "rotate" [bf (rad2deg r)] [buildS2 obj]
 
-buildS2 (Outset2 r obj) | r == 0 = call "outset" [] $ [buildS2 obj]
+buildS2 (Outset2 r obj) | r == 0 = call "outset" [] [buildS2 obj]
 
-buildS2 (Shell2 r obj) | r == 0 =  call "shell" [] $ [buildS2 obj]
+buildS2 (Shell2 r obj) | r == 0 =  call "shell" [] [buildS2 obj]
 
 -- Generate errors for rounding requests. OpenSCAD does not support rounding.
-buildS2 (RectR _ _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
+buildS2 RectR{} = error "cannot provide roundness when exporting openscad; unsupported in target format."
 buildS2 (PolygonR _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
 buildS2 (UnionR2 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."
 buildS2 (DifferenceR2 _ _) = error "cannot provide roundness when exporting openscad; unsupported in target format."

Graphics/Implicit/Export/SymbolicObj2.hs

@@ -3,17 +3,17 @@
 -- Released under the GNU AGPLV3+, see LICENSE
 
 -- FIXME: why is all of this needed?
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
 
 -- This file symbolicaly renders contours and contour fillings.
 -- If it can't, it passes the puck to a marching-squares-like
 -- algorithm...
 
-module Graphics.Implicit.Export.SymbolicObj2 where
+module Graphics.Implicit.Export.SymbolicObj2 (symbolicGetOrientedContour, symbolicGetContour, symbolicGetContourMesh) where
 
 import Prelude(map, ($), (-), (/), (+), (>), (*), (.), reverse, cos, pi, sin, max, fromInteger, ceiling)
 
-import Graphics.Implicit.Definitions (ℝ, ℝ2, SymbolicObj2(RectR, Circle, Translate2, Scale2), Polyline, (⋯*))
+import Graphics.Implicit.Definitions (ℝ, ℝ2, SymbolicObj2(RectR, Circle, Translate2, Scale2), Polyline(Polyline), Polytri(Polytri), (⋯*))
 
 import Graphics.Implicit.Export.MarchingSquaresFill (getContourMesh)
 
@@ -29,37 +29,44 @@ symbolicGetOrientedContour :: ℝ ->  SymbolicObj2 -> [Polyline]
 symbolicGetOrientedContour res symbObj = map orient $ symbolicGetContour res symbObj
     where
         obj = getImplicit2 symbObj
+        -- FIXME: cowardly case handling.
         orient :: Polyline -> Polyline
-        orient [] = []
-        orient [_] = []
-        orient points@(x:y:_) =
+        orient (Polyline (points@(x:y:_))) =
             let
                 v = (\(a,b) -> (b, -a)) (y - x)
                 dv = v ^/ (magnitude v / res / 0.1)
             in if obj (x + dv) - obj x > 0
-            then points
-            else reverse points
+            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
+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*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 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'
 
+appOpPolylines :: (ℝ2 -> ℝ2) -> [Polyline] -> [Polyline]
+appOpPolylines op polylines = map (appOpPolyline op) polylines
+appOpPolyline :: (ℝ2 -> ℝ2) -> Polyline -> Polyline
+appOpPolyline op (Polyline xs) = Polyline $ map op xs
 
-symbolicGetContourMesh :: ℝ ->  SymbolicObj2 -> [(ℝ2,ℝ2,ℝ2)]
-symbolicGetContourMesh res (Translate2 v obj) = map (\(a,b,c) -> (a + v, b + v, c + v) )  $
+symbolicGetContourMesh :: ℝ ->  SymbolicObj2 -> [Polytri]
+symbolicGetContourMesh res (Translate2 v obj) = map (\(Polytri (a,b,c)) -> (Polytri (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 (Scale2 s@(a,b) obj) = map (\(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)) = [((x1,y1), (x2,y1), (x2,y2)), ((x2,y2), (x1,y2), (x1,y1)) ]
+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),
+    [ Polytri ((0,0),
        (r*cos(2*pi*m/n), r*sin(2*pi*m/n)),
        (r*cos(2*pi*(m+1)/n), r*sin(2*pi*(m+1)/n))
       )| m <- [0.. n-1] ]
@@ -68,5 +75,3 @@ symbolicGetContourMesh res (Circle r) =
       n = max 5 (fromInteger . ceiling $ 2*pi*r/res)
 symbolicGetContourMesh res obj = case rebound2 (getImplicit2 obj, getBox2 obj) of
     (obj', (a,b)) -> getContourMesh a b (res,res) obj'
-
-

Graphics/Implicit/Export/SymbolicObj3.hs

@@ -6,22 +6,24 @@
 {-# LANGUAGE ExplicitForAll #-}
 
 -- FIXME: why are these needed?
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
 
 -- The purpose of this function is to symbolicaly compute triangle meshes using the symbolic system where possible.
 -- Otherwise we coerce it into an implicit function and apply our modified marching cubes algorithm.
 
 module Graphics.Implicit.Export.SymbolicObj3 (symbolicGetMesh) where
 
-import Prelude(map, zip, length, filter, (>), ($), null, concat, (++), concatMap)
+import Prelude(map, zip, length, filter, (>), ($), null, (++), concatMap)
 
-import Graphics.Implicit.Definitions (ℝ, ℝ3, SymbolicObj3(UnionR3))
+import Graphics.Implicit.Definitions (ℝ, ℝ3, SymbolicObj3(UnionR3), Triangle, TriangleMesh(TriangleMesh))
 import Graphics.Implicit.Export.Render (getMesh)
 import Graphics.Implicit.ObjectUtil (getBox3, getImplicit3)
 import Graphics.Implicit.MathUtil(box3sWithin)
 import Graphics.Implicit.Export.Symbolic.Rebound3 (rebound3)
 
-symbolicGetMesh :: ℝ -> SymbolicObj3 -> [(ℝ3, ℝ3, ℝ3)]
+import Control.Arrow(first, second)
+
+symbolicGetMesh :: ℝ -> SymbolicObj3 -> TriangleMesh
 
 {--
 -- A translated objects mesh is its mesh translated.
@@ -195,32 +197,32 @@ symbolicGetMesh res  (ExtrudeRM r twist scale translate obj2 h) =
         map 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
         boxedObjs = zip boxes objs
-        
+
         sepFree :: forall a. [((ℝ3, ℝ3), a)] -> ([a], [a])
-        sepFree ((box,obj):others) = 
+        sepFree ((box,obj):others) =
             if length (filter (box3sWithin r box) boxes) > 1
-            then (\(a,b) -> (obj:a,b)) $ sepFree others
-            else (\(a,b) -> (a,obj:b)) $ sepFree others
+            then first ((:) obj) $ sepFree others
+            else second ((:) obj) $ sepFree others
         sepFree [] = ([],[])
 
         (dependants, independents) = sepFree boxedObjs
     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 obj
     else if null dependants
-    then concatMap (symbolicGetMesh res) independents
-    else concatMap (symbolicGetMesh res) independents
-        ++ concat [symbolicGetMesh res (UnionR3 r dependants)]
+    then concatMap unmesh $ map (symbolicGetMesh res) independents
+    else  (concatMap unmesh $ map (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 obj'
 
+unmesh :: TriangleMesh -> [Triangle]
+unmesh (TriangleMesh m) = m

Graphics/Implicit/Export/TextBuilderUtils.hs

@@ -5,51 +5,52 @@
 -- This module exists to re-export a coherent set of functions to define
 -- Data.Text.Lazy builders with.
 
-module Graphics.Implicit.Export.TextBuilderUtils  
-    (
-     -- Values from Data.Text.Lazy
-     Text,
-     pack,
-     -- Values from Data.Text.Lazy.Builder, as well as some special builders
-     Builder,
+module Graphics.Implicit.Export.TextBuilderUtils (
+     -- 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,
+     buildℕ,
+     buildInt,
      -- Values from Data.Monoid
      (<>),
      mconcat,
      mempty
     ) where
 
-import Prelude (Int, Maybe(Nothing, Just), ($))
+import Prelude (Maybe(Nothing, Just), Int, ($))
 
-import Data.Text.Lazy (Text, pack)
+import Graphics.Implicit.Definitions (ℝ, ℕ, fromℝtoFloat)
+import Data.Text.Lazy as DTL (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 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
 
+buildℕ :: ℕ -> Builder
+buildℕ = decimal
+
 buildInt :: Int -> Builder
 buildInt = decimal
 

Graphics/Implicit/Export/TriangleMeshFormats.hs

@@ -8,31 +8,78 @@
 -- Make string litearls more polymorphic, so we can use them with Builder.
 {-# LANGUAGE OverloadedStrings #-}
 
-module Graphics.Implicit.Export.TriangleMeshFormats where
+-- This module exposes three functions, which convert a triangle mesh to an output file.
+module Graphics.Implicit.Export.TriangleMeshFormats (stl, binaryStl, jsTHREE) where
 
-import Prelude (Real, Float, Int, ($), (+), map, (.), realToFrac, toEnum, length, zip, return)
+import Prelude (Float, Eq, Bool, ($), (+), map, (.), toEnum, length, zip, return, (==), (||), (&&), filter, not)
 
-import Graphics.Implicit.Definitions (Triangle, TriangleMesh, ℝ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.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)
 
-stl :: [Triangle] -> Text
-stl triangles = toLazyText $ stlHeader <> mconcat (map triangle triangles) <> stlFooter
+-- | 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)
+
+{-
+
+   -- Alternate methods of detecting degenerate triangles -- not used.
+   -- If you have to use one of these, please tell the maintainer.
+
+        -- | Does this triangle fail because it's points are on the same line?
+        isDegenerateTriLine (p1,p2,p3) = (norm (p1,p2)) == (norm (p2,p3)) || (norm (p1,p3)) == (norm(p2,p3))
+          where
+            norm :: ((Float,Float,Float),(Float,Float,Float)) -> (Float,Float,Float)
+            norm (begin, end) = normalized $ begin ^-^ end
+        -- | Does this triangle fail because of two of it's points overlap?
+        isDegenerateTriPoint :: Eq t => (t,t,t) -> Bool
+        isDegenerateTriPoint (a,b,c) = (a == b) || (b == c) || (a == c)
+
+-}
+
+        -- | Does this triangle fail because it is constrained on two axises?
+        isDegenerateTri2Axis :: forall a. (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 :: forall a. Eq a => (a, a, a) -> Bool
+            same (n1, n2, n3) = n1 == n2 && n2 == n3
+            xsame :: forall a. Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
+            xsame ((x1,_,_),(x2,_,_),(x3,_,_)) = same (x1, x2, x3)
+            ysame :: forall a. Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool
+            ysame ((_,y1,_),(_,y2,_),(_,y3,_)) = same (y1, y2, y3)
+            zsame :: forall a. 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 $ unmesh $ cleanupTris triangles) <> stlFooter
     where
         stlHeader :: Builder
         stlHeader = "solid ImplictCADExport\n"
@@ -42,8 +89,8 @@ stl triangles = toLazyText $ stlHeader <> mconcat (map triangle triangles) <> st
         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"
@@ -51,25 +98,23 @@ stl triangles = toLazyText $ stlHeader <> mconcat (map triangle triangles) <> st
                 <> vertex c
                 <> "\nendloop\nendfacet\n"
 
+-- | convert from ℝ to Float.
+toFloat :: ℝ -> Float
+toFloat = fromℝtoFloat
 
--- 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
-
+-- | Write a 32-bit little-endian float to a buffer.
 float32LE :: Float -> Write
 float32LE = writeStorable . LE
 
-binaryStl :: [Triangle] -> ByteString
-binaryStl triangles = toLazyByteString $ header <> lengthField <> mconcat (map triangle triangles)
+-- | Generate an STL file in it's binary format.
+binaryStl :: TriangleMesh -> ByteString
+binaryStl triangles = toLazyByteString $ header <> lengthField <> mconcat (map 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
@@ -94,18 +139,18 @@ jsTHREE triangles = toLazyText $ header <> vertcode <> facecode <> footer
                 v :: ℝ3 -> Builder
                 v (x,y,z) = "v(" <> bf x <> "," <> bf y <> "," <> bf z <> ");\n"
                 -- A face line
-                f :: Int -> Int -> Int -> Builder
-                f posa posb posc = 
-                        "f(" <> buildInt posa <> "," <> buildInt posb <> "," <> buildInt posc <> ");"
+                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
+                        (n,_) <- zip [0, 3 ..] $ unmesh $ cleanupTris triangles
                         let
-                            (posa, posb, posc) = (n, n+1, n+2) :: (Int, Int, Int)
+                            (posa, posb, posc) = (n, n+1, n+2) :: (ℕ, ℕ, ℕ)
                         return $ f posa posb posc

Graphics/Implicit/Export/Util.hs

@@ -3,7 +3,7 @@
 -- Released under the GNU AGPLV3+, see LICENSE
 
 -- FIXME: why are these needed?
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
 
 -- Functions to make meshes/polylines finer.
 
@@ -11,13 +11,13 @@ module Graphics.Implicit.Export.Util (normTriangle, normVertex, centroid) where
 
 import Prelude(Fractional, (/), (-), ($), foldl, recip, 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)
 
 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
@@ -46,6 +46,7 @@ centroid pts =
     where
       norm :: Fractional a => a
       norm = recip $ realToFrac $ length pts
+{-# INLINABLE centroid #-}
 
 {--- If we need to make a 2D mesh finer...
 divideMesh2To :: ℝ -> [(ℝ2, ℝ2, ℝ2)] -> [(ℝ2, ℝ2, ℝ2)]

Graphics/Implicit/ExtOpenScad.hs

@@ -5,38 +5,39 @@
 -- FIXME: why are these required?
 {-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
 
--- We'd like to parse openscad code, with some improvements, for backwards compatability.
-
+-- An executor, which parses openscad code, and executes it.
 module Graphics.Implicit.ExtOpenScad (runOpenscad) where
 
-import Prelude(Char, Either(Left, Right), IO, ($), fmap)
+import Prelude(String, Either(Left, Right), IO, ($), fmap)
 
 import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3)
-import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup, OVal)
+import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup)
 import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram)
 import Graphics.Implicit.ExtOpenScad.Eval.Statement (runStatementI)
 import Graphics.Implicit.ExtOpenScad.Default (defaultObjects)
+import Graphics.Implicit.ExtOpenScad.Util.StateC (CompState(CompState))
 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)
 
--- Small wrapper to handle parse errors, etc.
-runOpenscad :: [Char] -> Either Parsec.ParseError (IO (VarLookup, [SymbolicObj2], [SymbolicObj3]))
-runOpenscad s =
+import Text.Parsec.Error (ParseError)
+import Control.Monad (mapM_)
+import Control.Monad.State (runStateT)
+import System.Directory (getCurrentDirectory)
+
+-- | Small wrapper of our parser to handle parse errors, etc.
+runOpenscad :: String -> Either 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
+        rearrange :: forall t. (t, CompState) -> (VarLookup, [SymbolicObj2], [SymbolicObj3])
+        rearrange (_, (CompState (varlookup, ovals, _))) = (varlookup, obj2s, obj3s) where
                                   (obj2s, obj3s, _ ) = divideObjs ovals
-    in case parseProgram "" s of
+    in case parseProgram source of
         Left e -> Left e
         Right sts -> Right
             $ fmap rearrange
             $ (\sts' -> do
-                path <- Dir.getCurrentDirectory
-                State.runStateT sts' (initial, [], path, (), () )
+                path <- getCurrentDirectory
+                runStateT sts' $ CompState (initial, [], path)
             )
-            $ Monad.mapM_ runStatementI sts
+            $ mapM_ runStatementI sts

Graphics/Implicit/ExtOpenScad/Default.hs

@@ -5,18 +5,20 @@
 -- 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.
+-- We'd like to parse openscad-ish code, with some improvements, for backwards compatability.
 
-module Graphics.Implicit.ExtOpenScad.Default where
+module Graphics.Implicit.ExtOpenScad.Default (defaultObjects) where
 
+-- be explicit about where we pull things in from.
+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, (-), otherwise)
 
-import Prelude (Char, String, Bool(True, False), Maybe(Just, Nothing), Int, ($), (++), map, pi, sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, abs, signum, fromInteger, (.), floor, ceiling, round, exp, log, sqrt, max, min, atan2, (**), flip, (<), (>), (<=), (>=), (==), (/=), (&&), (||), not, show, foldl, (*), (/), mod, (+), zipWith, (-), (!!), length, otherwise, fromIntegral)
-
-import Graphics.Implicit.Definitions (ℝ)
+import Graphics.Implicit.Definitions (ℝ, ℕ)
 import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup, OVal(OList, ONum, OString, OUndefined, OError, OModule, OFunc))
 import Graphics.Implicit.ExtOpenScad.Util.OVal (toOObj, oTypeStr)
 import Graphics.Implicit.ExtOpenScad.Primitives (primitives)
 import Data.Map (fromList)
+import Data.List (genericIndex, genericLength)
+import Control.Arrow (second)
 
 defaultObjects :: VarLookup -- = Map String OVal
 defaultObjects = fromList $
@@ -30,11 +32,11 @@ defaultObjects = fromList $
 -- Missing standard ones:
 -- rand, lookup,
 
-defaultConstants :: [([Char], OVal)]
+defaultConstants :: [(String, OVal)]
 defaultConstants = map (\(a,b) -> (a, toOObj (b::ℝ) ))
     [("pi", pi)]
 
-defaultFunctions :: [([Char], OVal)]
+defaultFunctions :: [(String, OVal)]
 defaultFunctions = map (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ)))
     [
         ("sin",   sin),
@@ -58,7 +60,7 @@ defaultFunctions = map (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ)))
         ("sqrt",  sqrt)
     ]
 
-defaultFunctions2 :: [([Char], OVal)]
+defaultFunctions2 :: [(String, OVal)]
 defaultFunctions2 = map (\(a,b) -> (a, toOObj (b :: ℝ -> ℝ -> ℝ) ))
     [
         ("max", max),
@@ -67,25 +69,21 @@ defaultFunctions2 = map (\(a,b) -> (a, toOObj (b :: ℝ -> ℝ -> ℝ) ))
         ("pow", (**))
     ]
 
-defaultFunctionsSpecial :: [([Char], OVal)]
+defaultFunctionsSpecial :: [(String, OVal)]
 defaultFunctionsSpecial =
     [
-        ("map", toOObj $ flip $
+        ("map", toOObj $ flip
             (map :: (OVal -> OVal) -> [OVal] -> [OVal] )
         )
-        
     ]
 
-
 defaultModules :: [(String, OVal)]
 defaultModules =
-    map (\(a,b) -> (a, OModule b)) primitives
-
-
+    map (second OModule) primitives
 
 -- more complicated ones:
 
-defaultPolymorphicFunctions :: [([Char], OVal)]
+defaultPolymorphicFunctions :: [(String, OVal)]
 defaultPolymorphicFunctions =
     [
         ("+", sumtotal),
@@ -138,7 +136,7 @@ defaultPolymorphicFunctions =
         div' (OList a) (ONum b) = OList (map (\x -> div' x (ONum b)) a)
         div' a         b        = errorAsAppropriate "divide" a b
 
-        omod (ONum a) (ONum b) = ONum $ fromInteger $ mod (floor a) (floor b)
+        omod (ONum a) (ONum b) = ONum . fromInteger $ mod (floor a) (floor b)
         omod a        b        = errorAsAppropriate "modulo" a b
 
         append (OList   a) (OList   b) = OList   $ a++b
@@ -175,44 +173,46 @@ defaultPolymorphicFunctions =
 
         index (OList l) (ONum ind) =
             let
-                n :: Int
+                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 :: Int
+                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    ) =
             OList   $ splice list (floor a) (floor b)
         osplice (OString str) (ONum a) (    ONum b    ) =
             OString $ splice str  (floor a) (floor b)
-        osplice (OList  list) (OUndefined) (ONum b    ) =
+        osplice (OList  list)  OUndefined  (ONum b    ) =
             OList   $ splice list 0 (floor b)
-        osplice (OString str) (OUndefined) (ONum b    ) =
+        osplice (OString str)  OUndefined  (ONum b    ) =
             OString $ splice str  0 (floor b)
-        osplice (OList  list) (ONum a) (    OUndefined) =
-            OList   $ splice list (floor a) (length list + 1)
-        osplice (OString str) (ONum a) (    OUndefined) =
-            OString $ splice str  (floor a) (length str  + 1)
-        osplice (OList  list) (OUndefined) (OUndefined) =
-            OList   $ splice list 0 (length list + 1)
-        osplice (OString str) (OUndefined) (OUndefined) =
-            OString $ splice str  0 (length str  + 1)
+        osplice (OList  list) (ONum a)      OUndefined  =
+            OList   $ splice list (floor a) (genericLength list + 1)
+        osplice (OString str) (ONum a)      OUndefined  =
+            OString $ splice str  (floor a) (genericLength str  + 1)
+        osplice (OList  list)  OUndefined   OUndefined  =
+            OList   $ splice list 0 (genericLength list + 1)
+        osplice (OString str)  OUndefined   OUndefined =
+            OString $ splice str  0 (genericLength str  + 1)
         osplice _ _ _ = OUndefined
 
-        splice :: [a] -> Int -> Int -> [a]
+        splice :: [a] -> ℕ -> ℕ -> [a]
         splice [] _ _     = []
         splice (l@(x:xs)) a b
             |    a < 0  =    splice l   (a+n)  b
             |    b < 0  =    splice l    a    (b+n)
             |    a > 0  =    splice xs  (a-1) (b-1)
-            |    b > 0  = x:(splice xs   a    (b-1) )
+            |    b > 0  = x: splice xs   a    (b-1)
             | otherwise = []
-                    where n = length l
+                    where
+                      n :: ℕ
+                      n = genericLength l
 
         errorAsAppropriate _   err@(OError _)   _ = err
         errorAsAppropriate _   _   err@(OError _) = err
@@ -220,24 +220,24 @@ defaultPolymorphicFunctions =
             ["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 $ map 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 $ map fromInteger $
+                [(ceiling a), (ceiling (a+b)).. (floor (c - b*(nr -n)))]
+            else Just $ map fromInteger $
+                [(ceiling a), (ceiling (a+b)).. (floor c)]
         list_gen _ = Nothing
 
         ternary :: forall t. 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 (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

@@ -14,14 +14,18 @@ module Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch
                                                   TestInvariant(EulerCharacteristic),
                                                   collector) where
 
-import Prelude(Eq, Show, String, Maybe, Bool(True, False), Int, IO, (==), show, map, ($), (++), undefined, all, id, zipWith, foldl1)
+import Prelude(Eq, Show, String, Maybe, Bool(True, False), IO, (==), show, map, ($), (++), undefined, and, zipWith, foldl1)
 
-import Graphics.Implicit.Definitions (ℝ, SymbolicObj2, SymbolicObj3)
+-- Resolution of the world, Integer type, and symbolic languages for 2D and 3D objects.
+import Graphics.Implicit.Definitions (ℝ, ℕ, SymbolicObj2, SymbolicObj3)
 
 import Control.Applicative (Applicative, Alternative((<|>), empty), pure, (<*>))
-import Control.Monad (Functor, Monad, fmap, (>>=), mzero, mplus, MonadPlus, liftM, ap, return)
+import Control.Monad (Functor, Monad, fmap, (>>=), mzero, mplus, MonadPlus, liftM, ap, return, (>=>))
 import Data.Map (Map)
 
+-- for keeping track of the line and column number we are on in our extopenscad file.
+import Text.ParserCombinators.Parsec (Line, Column)
+
 -----------------------------------------------------------------
 -- | Handles parsing arguments to modules
 data ArgParser a
@@ -45,14 +49,14 @@ instance Functor ArgParser where
     fmap = liftM
 
 instance Applicative ArgParser where
-    pure a = APTerminator a
+    pure = APTerminator
     (<*>) = ap
 
 instance Monad ArgParser where
     -- We need to describe how (>>=) works.
     -- Let's get the hard ones out of the way first.
     -- ArgParser actually
-    (AP str fallback d f) >>= g = AP str fallback d (\a -> (f a) >>= g)
+    (AP str fallback d f) >>= g = AP str fallback d (f >=> g)
     (APFailIf b errmsg child) >>= g = APFailIf b errmsg (child >>= g)
     -- These next to is easy, they just pass the work along to their child
     (APExample str child) >>= g = APExample str (child >>= g)
@@ -60,13 +64,13 @@ instance Monad ArgParser where
     -- And an ArgParserTerminator happily gives away the value it contains
     (APTerminator a) >>= g = g a
     (APBranch bs) >>= g = APBranch $ map (>>= g) bs
-    return g = APTerminator g
+    return = pure
 
 instance MonadPlus ArgParser where
     mzero = APFailIf True "" undefined
     mplus (APBranch as) (APBranch bs) = APBranch ( as  ++  bs )
     mplus (APBranch as) b             = APBranch ( as  ++ [b] )
-    mplus a             (APBranch bs) = APBranch ( [a] ++  bs )
+    mplus a             (APBranch bs) = APBranch ( a   :   bs )
     mplus a             b             = APBranch [ a   ,   b  ]
 
 instance Alternative ArgParser where
@@ -75,8 +79,8 @@ instance Alternative ArgParser where
 
 type Symbol = String
 
-data Pattern = Name  Symbol
-             | ListP  [Pattern]
+data Pattern = Name Symbol
+             | ListP [Pattern]
              | Wild
              | Symbol :@ Pattern
     deriving (Show, Eq)
@@ -88,7 +92,8 @@ data Expr = Var Symbol
           | Expr :$ [Expr]
     deriving (Show, Eq)
 
-data StatementI = StatementI Int (Statement StatementI)
+-- a statement, along with the line and column number it is found on.
+data StatementI = StatementI Line Column (Statement StatementI)
     deriving (Show, Eq)
 
 data Statement st = Include String Bool
@@ -118,7 +123,7 @@ data OVal = OUndefined
 instance Eq OVal where
     (OBool a) == (OBool b) = a == b
     (ONum  a) == (ONum  b) = a == b
-    (OList a) == (OList b) = all id $ zipWith (==) a b
+    (OList a) == (OList b) = and $ zipWith (==) a b
     (OString a) == (OString b) = a == b
     _ == _ = False
 
@@ -141,6 +146,6 @@ collector :: Symbol -> [Expr] -> Expr
 collector _ [x] = x
 collector s  l  = Var s :$ [ListE l]
 
-data TestInvariant = EulerCharacteristic Int
+newtype TestInvariant = EulerCharacteristic ℕ
     deriving (Show)
 

Graphics/Implicit/ExtOpenScad/Eval/Expr.hs

@@ -4,7 +4,7 @@
 
 module Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, matchPat) where
 
-import Prelude (String, Maybe(Just, Nothing), IO, concat, ($), map, return, zip, (==), (!!), const, (++), foldr, concatMap)
+import Prelude (String, Maybe(Just, Nothing), IO, concat, ($), map, return, zip, (!!), const, (++), foldr, concatMap)
 
 import Graphics.Implicit.ExtOpenScad.Definitions (
                                                   Pattern(Name, ListP, Wild),
@@ -15,11 +15,12 @@ import Graphics.Implicit.ExtOpenScad.Definitions (
 import Graphics.Implicit.ExtOpenScad.Util.OVal (oTypeStr, getErrors)
 import Graphics.Implicit.ExtOpenScad.Util.StateC (StateC, getVarLookup)
 
-import Data.List (findIndex)
+import Data.List (elemIndex)
 import Data.Map (fromList, lookup)
 import Control.Monad (zipWithM, mapM, forM)
 import Control.Monad.State (StateT, get, modify, liftIO, runStateT)
 
+import Control.Arrow (second)
 
 patVars :: Pattern -> [String]
 patVars (Name  name) = [name]
@@ -40,22 +41,19 @@ matchPat pat val = do
     vals <- patMatch pat val
     return $ fromList $ zip vars vals
 
-
 evalExpr :: Expr -> StateC OVal
 evalExpr expr = do
     varlookup  <- getVarLookup
     (valf, _) <- liftIO $ runStateT (evalExpr' expr) (varlookup, [])
     return $ valf []
 
-
-
 evalExpr' :: Expr -> StateT (VarLookup, [String]) IO ([OVal] -> OVal)
 
 evalExpr' (Var   name ) = do
     (varlookup, namestack) <- get
     return $
-        case (lookup name varlookup, findIndex (==name) namestack) of
-            (_, Just pos) -> \s -> s !! pos
+        case (lookup name varlookup, elemIndex name namestack) of
+            (_, Just pos) -> (!! pos)
             (Just val, _) -> const val
             _             -> const $ OError ["Variable " ++ name ++ " not in scope" ]
 
@@ -80,7 +78,7 @@ evalExpr' (fexpr :$ argExprs) = do
 
 evalExpr' (LamE pats fexpr) = do
     fparts <- forM pats $ \pat -> do
-        modify (\(vl, names) -> (vl, patVars pat ++ names))
+        modify (second (patVars pat ++))
         return $ \f xss -> OFunc $ \val -> case patMatch pat val of
             Just xs -> f (xs ++ xss)
             Nothing -> OError ["Pattern match failed"]

Graphics/Implicit/ExtOpenScad/Eval/Statement.hs

@@ -2,9 +2,10 @@
 -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)
 -- Released under the GNU AGPLV3+, see LICENSE
 
-{-# LANGUAGE ViewPatterns, ScopedTypeVariables #-}
+-- FIXME: why is this required?
+{-# LANGUAGE ScopedTypeVariables #-}
 
-module Graphics.Implicit.ExtOpenScad.Eval.Statement where
+module Graphics.Implicit.ExtOpenScad.Eval.Statement (runStatementI) where
 
 import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left, Right), FilePath, IO, (.), ($), show, putStrLn, concatMap, return, (++), fmap, reverse, fst, readFile)
 
@@ -19,63 +20,68 @@ import Graphics.Implicit.ExtOpenScad.Definitions (
 
 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 (StateC, CompState(CompState), errorC, modifyVarLookup, mapMaybeM, lookupVar, pushVals, getRelPath, withPathShiftedBy, getVals, putVals)
 import Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, matchPat)
 import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram)
 
-import qualified Data.Map as Map
-import qualified Control.Monad as Monad
+import Data.Maybe(fromMaybe)
+
+import Data.Map (union, fromList)
+
+import Control.Monad (forM_, forM, mapM_)
+
 import Control.Monad.State (get, liftIO, mapM, runStateT, (>>))
-import qualified System.FilePath as FilePath
+
+import System.FilePath (takeDirectory)
 
 -- Run statements out of the OpenScad file.
 runStatementI :: StatementI -> StateC ()
 
-runStatementI (StatementI lineN (pat := expr)) = do
+runStatementI (StatementI lineN columnN (pat := expr)) = do
     val <- evalExpr expr
     let posMatch = matchPat pat val
     case (getErrors val, posMatch) of
-        (Just err,  _ ) -> errorC lineN err
-        (_, Just match) -> modifyVarLookup $ Map.union match
-        (_,   Nothing ) -> errorC lineN "pattern match failed in assignment"
+        (Just err,  _ ) -> errorC lineN columnN err
+        (_, Just match) -> modifyVarLookup $ union match
+        (_,   Nothing ) -> errorC lineN columnN "pattern match failed in assignment"
 
-runStatementI (StatementI lineN (Echo exprs)) = do
+runStatementI (StatementI lineN columnN (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
+        Just err -> errorC lineN columnN err
 
-runStatementI (StatementI lineN (For pat expr loopContent)) = do
+runStatementI (StatementI lineN columnN (For pat expr loopContent)) = do
     val <- evalExpr expr
     case (getErrors val, val) of
-        (Just err, _)      -> errorC lineN err
-        (_, OList vals) -> Monad.forM_ vals $ \v ->
+        (Just err, _)      -> errorC lineN columnN err
+        (_, OList vals) -> forM_ vals $ \v ->
             case matchPat pat v of
                 Just match -> do
-                    modifyVarLookup $ Map.union match
+                    modifyVarLookup $ union match
                     runSuite loopContent
                 Nothing -> return ()
         _ -> return ()
 
-runStatementI (StatementI lineN (If expr a b)) = do
+runStatementI (StatementI lineN columnN (If expr a b)) = do
     val <- evalExpr expr
     case (getErrors val, val) of
-        (Just err,  _  )  -> errorC lineN ("In conditional expression of if statement: " ++ err)
+        (Just err,  _  )  -> errorC lineN columnN ("In conditional expression of if statement: " ++ err)
         (_, OBool True )  -> runSuite a
         (_, OBool False)  -> runSuite b
         _                 -> return ()
 
-runStatementI (StatementI lineN (NewModule name argTemplate suite)) = do
-    argTemplate' <- Monad.forM argTemplate $ \(name', defexpr) -> do
+runStatementI (StatementI lineN columnN (NewModule name argTemplate suite)) = do
+    argTemplate' <- forM argTemplate $ \(name', defexpr) -> do
         defval <- mapMaybeM evalExpr defexpr
         return (name', defval)
-    (varlookup, _, path, _, _) <- get
+    (CompState (varlookup, _, path)) <- get
 --  FIXME: \_? really?
-    runStatementI $ StatementI lineN $ (Name name :=) $ LitE $ OModule $ \_ -> do
-        newNameVals <- Monad.forM argTemplate' $ \(name', maybeDef) -> do
+    runStatementI . StatementI lineN columnN $ (Name name :=) $ LitE $ OModule $ \_ -> do
+        newNameVals <- forM argTemplate' $ \(name', maybeDef) -> do
             val <- case maybeDef of
                 Just def -> argument name' `defaultTo` def
                 Nothing  -> argument name'
@@ -97,57 +103,53 @@ runStatementI (StatementI lineN (NewModule name argTemplate suite)) = do
                 _ -> OUndefined
             newNameVals' = newNameVals ++ [("children", children),("child", child), ("childBox", childBox)]
 -}
-            varlookup' = Map.union (Map.fromList newNameVals) varlookup
+            varlookup' = union (fromList newNameVals) varlookup
             suiteVals  = runSuiteCapture varlookup' path suite
         return suiteVals
 
-runStatementI (StatementI lineN (ModuleCall name argsExpr suite)) = do
+runStatementI (StatementI lineN columnN (ModuleCall name argsExpr suite)) = do
         maybeMod  <- lookupVar name
-        (varlookup, _, path, _, _) <- get
+        (CompState (varlookup, _, path)) <- get
         childVals <- fmap reverse . liftIO $ runSuiteCapture varlookup path suite
-        argsVal   <- Monad.forM argsExpr $ \(posName, expr) -> do
+        argsVal   <- forM argsExpr $ \(posName, expr) -> do
             val <- evalExpr expr
             return (posName, val)
         newVals <- case maybeMod of
             Just (OModule mod') -> liftIO ioNewVals where
                 argparser = mod' childVals
-                ioNewVals = case fst $ argMap argsVal argparser of
-                    Just iovals -> iovals
-                    Nothing     -> return []
+                ioNewVals = fromMaybe (return []) (fst $ argMap argsVal argparser)
             Just foo            -> do
                     case getErrors foo of
-                        Just err -> errorC lineN err
-                        Nothing  -> errorC lineN $ "Object called not module!"
+                        Just err -> errorC lineN columnN err
+                        Nothing  -> errorC lineN columnN "Object called not module!"
                     return []
             Nothing -> do
-                errorC lineN $ "Module " ++ name ++ " not in scope."
+                errorC lineN columnN $ "Module " ++ name ++ " not in scope."
                 return []
         pushVals newVals
 
-runStatementI (StatementI _ (Include name injectVals)) = do
+runStatementI (StatementI _ _ (Include name injectVals)) = do
     name' <- getRelPath name
     content <- liftIO $ readFile name'
-    case parseProgram name content of
+    case parseProgram content of
         Left e -> liftIO $ putStrLn $ "Error parsing " ++ name ++ ":" ++ show e
-        Right sts -> withPathShiftedBy (FilePath.takeDirectory name) $ do
+        Right sts -> withPathShiftedBy (takeDirectory name) $ do
             vals <- getVals
             putVals []
             runSuite sts
             vals' <- getVals
             if injectVals then putVals (vals' ++ vals) else putVals vals
 
-
-runStatementI (StatementI _ DoNothing) = do
-  liftIO $ putStrLn $ "Do Nothing?"
+runStatementI (StatementI _ _ DoNothing) = liftIO $ putStrLn "Do Nothing?"
 
 runSuite :: [StatementI] -> StateC ()
-runSuite stmts = Monad.mapM_ runStatementI stmts
+runSuite = mapM_ runStatementI
 
 runSuiteCapture :: VarLookup -> FilePath -> [StatementI] -> IO [OVal]
 runSuiteCapture varlookup path suite = do
     (res, _) <- runStateT
         (runSuite suite >> getVals)
-        (varlookup, [], path, (), () )
+        (CompState (varlookup, [], path))
     return res
 
 

Graphics/Implicit/ExtOpenScad/Parser/Expr.hs

@@ -2,17 +2,16 @@
 -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)
 -- Released under the GNU AGPLV3+, see LICENSE
 
-module Graphics.Implicit.ExtOpenScad.Parser.Expr where
+-- a parser for a numeric expression.
+module Graphics.Implicit.ExtOpenScad.Parser.Expr(expr0) where
 
-import Prelude (Char, Maybe(Nothing, Just), fmap, ($), (>>), return, Bool(True, False), read, (++), id, foldl, map, foldl1, unzip, tail, zipWith3)
-
--- the datatype representing the graininess of our world.
-import Graphics.Implicit.Definitions (ℝ)
+import Prelude (Char, Maybe(Nothing, Just), fmap, ($), (.), (>>), return, Bool(True, False), read, (++), (*), (**), (/), id, foldl, map, foldl1, unzip, tail, zipWith3, foldr)
 
 -- The parsec parsing library.
 import Text.ParserCombinators.Parsec (GenParser, string, many1, digit, char, many, noneOf, sepBy, sepBy1, optionMaybe, try)
 
-import Graphics.Implicit.ExtOpenScad.Definitions (Expr(Var, LitE, ListE, (:$)), OVal(ONum, OString, OBool, OUndefined), collector) 
+import Graphics.Implicit.ExtOpenScad.Definitions (Expr(Var, LamE, LitE, ListE, (:$)), OVal(ONum, OString, OBool, OUndefined), collector, Pattern(Name))
+
 import Graphics.Implicit.ExtOpenScad.Parser.Util (variableSymb, (?:), (*<|>), genSpace, padString)
 
 variable :: GenParser Char st Expr
@@ -23,27 +22,87 @@ literal = ("literal" ?:) $
     "boolean" ?: do
         b  <-      (string "true"  >> return True )
               *<|> (string "false" >> return False)
-        return $ LitE $ OBool b
+        return . LitE $ OBool b
+    -- FIXME: this is a hack, implement something like exprN to replace this?
     *<|> "number" ?: (
-        do
+         do
+            a <- many1 digit
+            _ <- char 'e'
+            b <- many1 digit
+            return . LitE $ ONum $ read a * (10 ** read b)
+        *<|>  do
             a <- many1 digit
             _ <- char '.'
             b <- many digit
-            return $ LitE $ ONum (read (a ++ "." ++ b) :: ℝ)
+            _ <- char 'e'
+            c <- many1 digit
+            return . LitE $ ONum $ read (a ++ "." ++ b) * (10 ** read c)
         *<|>  do
             a <- many1 digit
-            return $ LitE $ ONum (read a :: ℝ)
+            _ <- char '.'
+            b <- many digit
+            _ <- char 'e'
+            _ <- char '+'
+            c <- many1 digit
+            return . LitE $ ONum $ read (a ++ "." ++ b) * (10 ** read c)
+        *<|>  do
+            a <- many1 digit
+            _ <- char '.'
+            b <- many digit
+            _ <- char 'e'
+            _ <- char '-'
+            c <- many1 digit
+            return . LitE $ ONum $ read (a ++ "." ++ b) / (10 ** read c)
+        *<|>  do
+            a <- many1 digit
+            _ <- char 'e'
+            _ <- char '-'
+            b <- many1 digit
+            return . LitE $ ONum $ read a / (10 ** read b)
+        *<|>  do
+            a <- many1 digit
+            _ <- char '.'
+            b <- many digit
+            return . LitE $ ONum $ read (a ++ "." ++ b)
+        *<|>  do
+            a <- many1 digit
+            return . LitE $ ONum $ read a
         )
-    *<|> "string" ?: do
+     *<|> "string" ?: do
         _ <- string "\""
         strlit <-  many $ (string "\\\"" >> return '\"')
                      *<|> (string "\\n" >> return '\n')
-                     *<|> ( noneOf "\"\n")
+                     *<|> (string "\\r" >> return '\r')
+                     *<|> (string "\\t" >> return '\t')
+                     *<|> (string "\\\\" >> return '\\')
+                      -- FIXME: no \u unicode support?
+                     *<|> noneOf "\"\n"
         _ <- string "\""
-        return $ LitE $ OString strlit
+        return . LitE $ OString strlit
+
+letExpr :: GenParser Char st Expr
+letExpr = "let expression" ?: do
+  _ <- string "let"
+  _ <- genSpace
+  _ <- string "("
+  _ <- genSpace
+  bindingPairs <- sepBy ( do
+    _ <- genSpace
+    boundName <- variableSymb
+    _ <- genSpace
+    _ <- string "="
+    _ <- genSpace
+    boundExpr <- expr0
+    return $ ListE [Var boundName, boundExpr])
+    (char ',')
+  _ <- string ")"
+  expr <- expr0
+  let bindLets (ListE [Var boundName, boundExpr]) nestedExpr = (LamE [Name boundName] nestedExpr) :$ [boundExpr]
+      bindLets _ e = e
+  return $ foldr bindLets expr bindingPairs
 
 -- We represent the priority or 'fixity' of different types of expressions
--- by the Int argument
+-- by the ExprIdx argument, with A0 as the highest.
 
 expr0 :: GenParser Char st Expr
 expr0 = exprN A0
@@ -55,6 +114,7 @@ exprN :: ExprIdx -> GenParser Char st Expr
 
 exprN A12 =
          literal
+    *<|> letExpr
     *<|> variable
     *<|> "bracketed expression" ?: do
         -- eg. ( 1 + 5 )
@@ -85,7 +145,7 @@ exprN A12 =
 
 exprN A11 =
     do
-        obj <- exprN $ A12
+        obj <- exprN A12
         _ <- genSpace
         mods <- many1 (
             "function application" ?: do
@@ -111,67 +171,73 @@ exprN A11 =
                     (Just s,  Just e )  -> \l -> Var "splice" :$ [l, s, e]
             )
         return $ foldl (\a b -> b a) obj mods
-    *<|> (exprN $ A12 )
+    *<|> exprN A12
 
+-- match a leading (+) or (-) operator.
 exprN A10 =
     "negation" ?: do
         _ <- padString "-"
-        expr <- exprN $ A11
+        expr <- exprN A11
         return $ Var "negate" :$ [expr]
     *<|> do
         _ <- padString "+"
-        expr <- exprN $ A11
-        return expr
-    *<|> exprN (A11)
+        exprN A11
+    *<|> exprN A11
 
+-- match power-of (^) operator.
 exprN A9 =
     "exponentiation" ?: do
-        a <- exprN $ A10
+        a <- exprN A10
         _ <- padString "^"
         b <- exprN A9
         return $ Var "^" :$ [a,b]
-    *<|> exprN (A10)
+    *<|> exprN A10
 
+-- match sequences of multiplication and division.
 exprN A8 =
     "multiplication/division" ?: do
         -- outer list is multiplication, inner division.
         -- eg. "1*2*3/4/5*6*7/8"
         --     [[1],[2],[3,4,5],[6],[7,8]]
         exprs <- sepBy1
-            (sepBy1 (exprN $ A9) (try $ padString "/" ))
+            (sepBy1 (exprN A9) (try $ padString "/" ))
             (try $ padString "*" )
         let div' a b = Var "/" :$ [a, b]
-        return $ collector "*" $ map (foldl1 div') exprs
-    *<|> exprN (A9)
+        return . collector "*" $ map (foldl1 div') exprs
+    *<|> exprN A9
 
+-- match remainder (%) operator.
 exprN A7 =
     "modulo" ?: do
-        exprs <- sepBy1 (exprN $ A8) (try $ padString "%")
+        exprs <- sepBy1 (exprN  A8) (try $ padString "%")
         let mod' a b = Var "%" :$ [a, b]
         return $ foldl1 mod' exprs
-    *<|> exprN (A8)
+    *<|> exprN A8
 
+-- match string addition (++) operator.
 exprN A6 =
     "append" ?: do
-        exprs <- sepBy1 (exprN $ A7) (try $ padString "++")
+        exprs <- sepBy1 (exprN A7) (try $ padString "++")
         return $ collector "++" exprs
-    *<|> exprN (A7)
+    *<|> exprN A7
 
+-- match sequences of addition and subtraction.
 exprN A5 =
     "addition/subtraction" ?: do
         -- Similar to multiply & divide
         -- eg. "1+2+3-4-5+6-7"
         --     [[1],[2],[3,4,5],[6,7]]
         exprs <- sepBy1
-            (sepBy1 (exprN $ A6) (try $ padString "-" ))
+            (sepBy1 (exprN A6) (try $ padString "-" ))
             (try $ padString "+" )
         let sub a b = Var "-" :$ [a, b]
-        return $ collector "+" $ map (foldl1 sub) exprs
-    *<|> exprN (A6)
+        return . collector "+" $ map (foldl1 sub) exprs
+    *<|> exprN A6
 
+-- match comparison operators.
 exprN A4 =
     do
-        firstExpr <- exprN $ A5
+        firstExpr <- exprN A5
         otherComparisonsExpr <- many $ do
             comparisonSymb <-
                      padString "=="
@@ -180,7 +246,7 @@ exprN A4 =
                 *<|> padString "<="
                 *<|> padString ">"
                 *<|> padString "<"
-            expr <- exprN $ A5
+            expr <- exprN A5
             return (Var comparisonSymb, expr)
         let
             (comparisons, otherExprs) = unzip otherComparisonsExpr
@@ -189,39 +255,43 @@ exprN A4 =
             []  -> firstExpr
             [x] -> x :$ exprs
             _   -> collector "all" $ zipWith3 (\c e1 e2 -> c :$ [e1,e2]) comparisons exprs (tail exprs)
-    *<|> exprN (A5)
+    *<|> exprN A5
 
+-- match the logical negation operator.
 exprN A3 =
     "logical-not" ?: do
         _ <- padString "!"
-        a <- exprN $ A4
+        a <- exprN A4
         return $ Var "!" :$ [a]
-    *<|> exprN (A4)
+    *<|> exprN A4
 
+-- match the logical And and Or (&&,||) operators.
 exprN A2 =
     "logical and/or" ?: do
-        a <- exprN $ A3
+        a <- exprN A3
         symb <-      padString "&&"
                 *<|> padString "||"
         b <- exprN A2
         return $ Var symb :$ [a,b]
-    *<|> exprN (A3)
+    *<|> exprN A3
 
+-- match the ternary (1?2:3) operator.
 exprN A1 =
     "ternary" ?: do
-        a <- exprN $ A2
+        a <- exprN A2
         _ <- padString "?"
         b <- exprN A1
         _ <- padString ":"
         c <- exprN A1
         return $ Var "?" :$ [a,b,c]
-    *<|> exprN (A2)
+    *<|> exprN A2
 
+-- Match and throw away any white space around an expression.
 exprN A0 =
     do
         _ <- genSpace
-        expr <- exprN $ A1
+        expr <- exprN A1
         _ <- genSpace
         return expr
-    *<|> exprN (A1)
+    *<|> exprN A1
 

Graphics/Implicit/ExtOpenScad/Parser/Statement.hs

@@ -8,29 +8,36 @@
 -- FIXME: required. why?
 {-# LANGUAGE KindSignatures #-}
 
-module Graphics.Implicit.ExtOpenScad.Parser.Statement where
+-- The entry point for parsing an ExtOpenScad program.
+module Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram) where
 
-import Prelude(Char, Either, String, Maybe(Just, Nothing), Monad, return, fmap, ($), (>>), Bool(False, True), map)
+import Prelude(Char, Either, String, Monad, return, fmap, ($), (>>), Bool(False, True), map)
 
-import Text.ParserCombinators.Parsec (try, sepBy, sourceLine, GenParser, oneOf, space, char, getPosition, parse, many1, eof, string, SourceName, ParseError, many, noneOf, Line, (<|>), (<?>))
-
-import Text.Parsec.Prim (ParsecT)
+import Data.Maybe(Maybe(Just, Nothing))
 
 import Data.Functor.Identity(Identity)
 
+import Data.Kind (Type)
+
+-- We use parsec to parse.
+import Text.ParserCombinators.Parsec (try, sepBy, sourceLine, sourceColumn, GenParser, oneOf, space, char, getPosition, parse, many1, eof, string, ParseError, many, noneOf, Line, Column, (<|>), (<?>))
+import Text.Parsec.Prim (ParsecT)
+
 import Graphics.Implicit.ExtOpenScad.Definitions (Pattern(Name), Statement(DoNothing, NewModule, Include, Echo, If, For, ModuleCall,(:=)),Expr(LamE), StatementI(StatementI))
 import Graphics.Implicit.ExtOpenScad.Parser.Util (genSpace, tryMany, stringGS, (*<|>), (?:), patternMatcher, variableSymb)
+
+-- the top level of the expression parser.
 import Graphics.Implicit.ExtOpenScad.Parser.Expr (expr0)
 
-parseProgram :: SourceName -> [Char] -> Either ParseError [StatementI]
-parseProgram name s = parse program name s where
-    program :: ParsecT [Char] u Identity [StatementI]
+parseProgram :: String -> Either ParseError [StatementI]
+parseProgram = parse program "" where -- "" is our program name.
+    program :: ParsecT String u Identity [StatementI]
     program = do
         sts <- many1 computation
         eof
         return sts
 
--- | A  in our programming openscad-like programming language.
+-- | A computable block of code in our openscad-like programming language.
 computation :: GenParser Char st StatementI
 computation =
     do -- suite statements: no semicolon...
@@ -39,30 +46,21 @@ computation =
             ifStatementI,
             forStatementI,
             throwAway,
-            userModuleDeclaration{-,
-            unimplemented "mirror",
-            unimplemented "multmatrix",
-            unimplemented "color",
-            unimplemented "render",
-            unimplemented "surface",
-            unimplemented "projection",
-            unimplemented "import_stl"-}
-            -- rotateExtrude
+            userModuleDeclaration
             ]
         _ <- genSpace
         return s
-    *<|> do -- Non suite s. Semicolon needed...
+    *<|> do -- Non suite statements. Semicolon needed...
         _ <- genSpace
         s <- tryMany [
             echo,
-            include,
+            include, -- also handles use
             function,
-            assignment--,
-            --use
+            assignment
             ]
         _ <- stringGS " ; "
         return s
-    *<|> do -- Modules
+    *<|> do -- Modules. no semicolon...
         _ <- genSpace
         s <- userModule
         _ <- genSpace
@@ -81,9 +79,8 @@ computation =
 --
 --      union() sphere(3);
 --
---  We consider it to be a list of s which
+--  We consider it to be a list of computables which
 --  are in turn StatementI s.
---  So this parses them.
 -}
 suite :: GenParser Char st [StatementI]
 suite = (fmap return computation <|> do
@@ -95,110 +92,120 @@ suite = (fmap return computation <|> do
     return stmts
     ) <?> " suite"
 
-
+-- | commenting out a comuptation: use % or * before the statement, and it will not be run.
 throwAway :: GenParser Char st StatementI
 throwAway = do
     line <- lineNumber
+    column <- columnNumber
     _ <- genSpace
     _ <- oneOf "%*"
     _ <- genSpace
     _ <- computation
-    return $ StatementI line DoNothing
+    return $ StatementI line column DoNothing
 
--- An included ! Basically, inject another openscad file here...
+-- | An include! Basically, inject another extopenscad file here...
 include :: GenParser Char st StatementI
 include = (do
     line <- lineNumber
+    column <- columnNumber
     injectVals <-  (string "include" >> return True )
                <|> (string "use"     >> return False)
     _ <- stringGS " < "
     filename <- many (noneOf "<> ")
     _ <- stringGS " > "
-    return $ StatementI line $ Include filename injectVals
+    return $ StatementI line column $ Include filename injectVals
     ) <?> "include "
 
--- | An assignment  (parser)
+-- | An assignment (parser)
 assignment :: GenParser Char st StatementI
 assignment = ("assignment " ?:) $
     do
         line <- lineNumber
-        pattern <- patternMatcher
+        column <- columnNumber
+        lvalue <- patternMatcher
         _ <- stringGS " = "
         valExpr <- expr0
-        return $ StatementI line$ pattern := valExpr
+        return $ StatementI line column $ lvalue := valExpr
 
 -- | A function declaration (parser)
 function :: GenParser Char st StatementI
 function = ("function " ?:) $
     do
         line <- lineNumber
-        varSymb <- (string "function" >> space >> genSpace >> variableSymb)
+        column <- columnNumber
+        varSymb <- string "function" >> space >> genSpace >> variableSymb
         _ <- stringGS " ( "
         argVars <- sepBy patternMatcher (stringGS " , ")
         _ <- stringGS " ) = "
         valExpr <- expr0
-        return $ StatementI line $ Name varSymb := LamE argVars valExpr
+        return $ StatementI line column $ Name varSymb := LamE argVars valExpr
 
--- | An echo  (parser)
+-- | An echo (parser)
 echo :: GenParser Char st StatementI
 echo = do
     line <- lineNumber
+    column <- columnNumber
     _ <- stringGS "echo ( "
-    exprs <- expr0 `sepBy` (stringGS " , ")
+    exprs <- expr0 `sepBy` stringGS " , "
     _ <- stringGS " ) "
-    return $ StatementI line $ Echo exprs
+    return $ StatementI line column $ Echo exprs
 
 ifStatementI :: GenParser Char st StatementI
 ifStatementI =
     "if " ?: do
         line <- lineNumber
+        column <- columnNumber
         _ <- stringGS "if ( "
         bexpr <- expr0
         _ <- stringGS " ) "
         sTrueCase <- suite
         _ <- genSpace
-        sFalseCase <- (stringGS "else " >> suite ) *<|> (return [])
-        return $ StatementI line $ If bexpr sTrueCase sFalseCase
+        sFalseCase <- (stringGS "else " >> suite ) *<|> return []
+        return $ StatementI line column $ If bexpr sTrueCase sFalseCase
 
 forStatementI :: GenParser Char st StatementI
 forStatementI =
     "for " ?: do
         line <- lineNumber
+        column <- columnNumber
         -- 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 ( "
-        pattern <- patternMatcher
+        lvalue <- patternMatcher
         _ <- stringGS " = "
         vexpr <- expr0
         _ <- stringGS " ) "
         loopContent <- suite
-        return $ StatementI line $ For pattern vexpr loopContent
+        return $ StatementI line column $ For lvalue vexpr loopContent
 
+-- | parse a call to a module.
 userModule :: GenParser Char st StatementI
 userModule = do
     line <- lineNumber
+    column <- columnNumber
     name <- variableSymb
     _ <- genSpace
     args <- moduleArgsUnit
     _ <- genSpace
     s <- suite *<|> (stringGS " ; " >> return [])
-    return $ StatementI line $ ModuleCall name args s
+    return $ StatementI line column $ ModuleCall name args s
 
+-- | declare a module.
 userModuleDeclaration :: GenParser Char st StatementI
 userModuleDeclaration = do
     line <- lineNumber
+    column <- columnNumber
     _ <- stringGS "module "
     newModuleName <- variableSymb
     _ <- genSpace
     args <- moduleArgsUnitDecl
     _ <- genSpace
     s <- suite
-    return $ StatementI line $ NewModule newModuleName args s
-
-----------------------
+    return $ StatementI line column $ NewModule newModuleName args s
 
+-- | parse the arguments passed to a module.
 moduleArgsUnit :: GenParser Char st [(Maybe String, Expr)]
 moduleArgsUnit = do
     _ <- stringGS " ( "
@@ -208,7 +215,7 @@ moduleArgsUnit = do
             symb <- variableSymb
             _ <- stringGS " = "
             expr <- expr0
-            return $ (Just symb, expr)
+            return (Just symb, expr)
         *<|> do
             -- eg. a(x,y) = 12
             symb <- variableSymb
@@ -216,7 +223,7 @@ moduleArgsUnit = do
             argVars <- sepBy variableSymb (try $ stringGS " , ")
             _ <- stringGS " ) = "
             expr <- expr0
-            return $ (Just symb, LamE (map Name argVars) expr)
+            return (Just symb, LamE (map Name argVars) expr)
         *<|> do
             -- eg. 12
             expr <- expr0
@@ -225,6 +232,7 @@ moduleArgsUnit = do
     _ <- stringGS " ) "
     return args
 
+-- | parse the arguments in the module declaration.
 moduleArgsUnitDecl ::  GenParser Char st [(String, Maybe Expr)]
 moduleArgsUnitDecl = do
     _ <- stringGS " ( "
@@ -241,8 +249,6 @@ moduleArgsUnitDecl = do
             _ <- sepBy variableSymb (try $ stringGS " , ")
             _ <- stringGS " ) = "
             expr <- expr0
--- FIXME: this line looks right, but.. what does this change?
---            return $ (Just symb, LamE (map Name argVars) expr)
             return (symb, Just expr)
         *<|> do
             symb <- variableSymb
@@ -251,13 +257,13 @@ moduleArgsUnitDecl = do
     _ <- stringGS " ) "
     return argTemplate
 
-lineNumber :: forall s u (m :: * -> *).
+-- | Find the line number. Used when generating errors.
+lineNumber :: forall s u (m :: Type -> Type).
               Monad m => ParsecT s u m Line
 lineNumber = fmap sourceLine getPosition
 
---FIXME: use the below function to improve error reporting.
-{-
-columnNumber :: forall s u (m :: * -> *).
+-- | Find the column number. Used when generating errors.
+columnNumber :: forall s u (m :: Type -> Type).
               Monad m => ParsecT s u m Column
 columnNumber = fmap sourceColumn getPosition
--}
+

Graphics/Implicit/ExtOpenScad/Parser/Util.hs

@@ -13,26 +13,31 @@ module Graphics.Implicit.ExtOpenScad.Parser.Util (genSpace, pad, (*<|>), (?:), s
 import Prelude (String, Char, ($), (++), foldl1, map, (>>), (.), return)
 
 import Text.ParserCombinators.Parsec (GenParser, many, oneOf, noneOf, (<|>), try, string, manyTill, anyChar, (<?>), char, many1, sepBy)
+
 import Text.Parsec.Prim (ParsecT, Stream)
+
 import Data.Functor.Identity (Identity)
+
 import Graphics.Implicit.ExtOpenScad.Definitions (Pattern(Wild, Name, ListP))
 
+import Data.Kind (Type)
+
 -- white space, including tabs, newlines and comments
-genSpace :: ParsecT [Char] u Identity [Char]
+genSpace :: ParsecT String u Identity String
 genSpace = many $
     oneOf " \t\n\r"
-    <|> (try $ do
+    <|> try ( do
         _ <- string "//"
         _ <- many ( noneOf "\n")
-        _ <- string "\n"
         return ' '
-    ) <|> (try $ do
+    ) <|> try ( do
         _ <- string "/*"
         _ <- manyTill anyChar (try $ string "*/")
         return ' '
     )
 
-pad :: forall b u. ParsecT [Char] u Identity b -> ParsecT [Char] u Identity b
+-- a padded ... parser?
+pad :: ParsecT String u Identity b -> ParsecT String u Identity b
 pad parser = do
     _ <- genSpace
     a <- parser
@@ -44,10 +49,10 @@ infixr 1 *<|>
 a *<|> b = try a <|> b
 
 infixr 2 ?:
-(?:) :: forall s u (m :: * -> *) a. String -> ParsecT s u m a -> ParsecT s u m a
+(?:) :: forall s u (m :: Type -> Type) a. String -> ParsecT s u m a -> ParsecT s u m a
 l ?: p = p <?> l
 
-stringGS :: [Char] -> ParsecT [Char] u Identity [Char]
+stringGS :: String -> ParsecT String u Identity String
 stringGS (' ':xs) = do
     x'  <- genSpace
     xs' <- stringGS xs
@@ -58,7 +63,8 @@ stringGS (x:xs) = do
     return (x' : xs')
 stringGS "" = return ""
 
-padString :: String -> ParsecT [Char] u Identity String
+-- a padded string
+padString :: String -> ParsecT String u Identity String
 padString s = do
     _ <- genSpace
     s' <- string s
@@ -66,10 +72,11 @@ padString s = do
     return s'
 
 tryMany :: forall u a tok. [GenParser tok u a] -> ParsecT [tok] u Identity a
-tryMany = (foldl1 (<|>)) . (map try)
+tryMany = foldl1 (<|>) . map try
 
-variableSymb :: forall s u (m :: * -> *). Stream s m Char => ParsecT s u m [Char]
+variableSymb :: forall s u (m :: Type -> Type). Stream s m Char => ParsecT s u m String
 variableSymb = many1 (noneOf " ,|[]{}()+-*&^%#@!~`'\"\\/;:.,<>?=") <?> "variable"
+{-# INLINABLE variableSymb #-}
 
 patternMatcher :: GenParser Char st Pattern
 patternMatcher =
@@ -88,7 +95,7 @@ patternMatcher =
     ) <|> ( do
         _ <- char '['
         _ <- genSpace
-        components <- patternMatcher `sepBy` (try $ genSpace >> char ',' >> genSpace)
+        components <- patternMatcher `sepBy` try (genSpace >> char ',' >> genSpace)
         _ <- genSpace
         _ <- char ']'
         return $ ListP components

Graphics/Implicit/ExtOpenScad/Primitives.hs

@@ -2,19 +2,22 @@
 -- 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 #-}
 
+-- For the type arithmatic involved in calling VectorSpace.
+{-# LANGUAGE TypeFamilies #-}
+
 -- Export one set containing all of the primitive object's patern matches.
 module Graphics.Implicit.ExtOpenScad.Primitives (primitives) where
 
-import Prelude(String, IO, Char, Either(Left, Right), Bool(False), Maybe(Just, Nothing), Fractional, ($), return, either, id, (-), (==), (&&), (<), fromIntegral, (*), cos, sin, pi, (/), (>), const, uncurry, realToFrac, fmap, fromInteger, round, (/=), (||), not, null, map, (++), putStrLn)
+import Prelude(String, IO, Either(Left, Right), Bool(False), Maybe(Just, Nothing), ($), return, either, id, (-), (==), (&&), (<), (*), cos, sin, pi, (/), (>), const, uncurry, fmap, fromInteger, round, (/=), (||), not, null, map, (++), putStrLn)
 
-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)
 
@@ -22,22 +25,23 @@ import Graphics.Implicit.ExtOpenScad.Util.ArgParser (doc, defaultTo, argument, e
 
 import Graphics.Implicit.ExtOpenScad.Util.OVal (caseOType, divideObjs, (<||>))
 
+-- 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 qualified Control.Monad as Monad
+import Control.Monad (mplus)
 
 import Data.VectorSpace (VectorSpace, Scalar, (*^))
-import GHC.Real (RealFrac)
 
-primitives :: [(String, [OVal] -> ArgParser (IO [OVal]) )]
+-- | The only thing exported here. basically, a list of functions, which accept OVal arguments and retrun an ArgParser ?
+primitives :: [(String, [OVal] -> ArgParser (IO [OVal]))]
 primitives = [ sphere, cube, square, cylinder, circle, polygon, union, difference, intersect, translate, scale, rotate, extrude, pack, shell, rotateExtrude, unit ]
 
--- sphere is a module without a suite.
--- this means that the parser will look for this like
---       sphere(args...);
-sphere :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+-- | sphere 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
     example "sphere(3);"
     example "sphere(r=5);"
@@ -52,14 +56,16 @@ sphere = moduleWithoutSuite "sphere" $ do
     -- (Graphics.Implicit.Primitives)
     addObj3 $ Prim.sphere r
 
-cube :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+cube :: (String, [OVal] -> ArgParser (IO [OVal]))
 cube = moduleWithoutSuite "cube" $ do
-
     -- examples
     example "cube(size = [2,3,4], center = true, r = 0.5);"
     example "cube(4);"
-
-    -- arguments
+    -- arguments shared between forms
+    r      :: ℝ    <- argument "r"
+                        `doc` "radius of rounding"
+                        `defaultTo` 0
+    -- arguments (two forms)
     ((x1,x2), (y1,y2), (z1,z2)) <-
         do
             x :: Either ℝ ℝ2 <- argument "x"
@@ -72,7 +78,7 @@ cube = moduleWithoutSuite "cube" $ do
                 `doc` "should center? (non-intervals)"
                 `defaultTo` False
             let
-                toInterval' :: Fractional t => t -> (t, t)
+                toInterval' :: ℝ -> (ℝ, ℝ)
                 toInterval' = toInterval center
             return (either toInterval' id x,
                     either toInterval' id y,
@@ -85,28 +91,24 @@ cube = moduleWithoutSuite "cube" $ do
                 `defaultTo` False
             let (x,y, z) = either (\w -> (w,w,w)) id size
             return (toInterval center x, toInterval center y, toInterval center z)
-
-    r      :: ℝ    <- argument "r"
-                        `doc` "radius of rounding"
-                        `defaultTo` 0
-
     -- Tests
     test "cube(4);"
         `eulerCharacteristic` 2
     test "cube(size=[2,3,4]);"
         `eulerCharacteristic` 2
-
     addObj3 $ Prim.rect3R r (x1, y1, z1) (x2, y2, z2)
 
-square :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+square :: (String, [OVal] -> ArgParser (IO [OVal]))
 square = moduleWithoutSuite "square" $ do
-
     -- examples
     example "square(x=[-2,2], y=[-1,5]);"
     example "square(size = [3,4], center = true, r = 0.5);"
     example "square(4);"
-
-    -- arguments
+    -- arguments shared between forms
+    r      :: ℝ    <- argument "r"
+                        `doc` "radius of rounding"
+                        `defaultTo` 0
+    -- arguments (two forms)
     ((x1,x2), (y1,y2)) <-
         do
             x :: Either ℝ ℝ2 <- argument "x"
@@ -117,7 +119,7 @@ square = moduleWithoutSuite "square" $ do
                 `doc` "should center? (non-intervals)"
                 `defaultTo` False
             let
-                toInterval' :: Fractional t => t -> (t, t)
+                toInterval' :: ℝ -> (ℝ, ℝ)
                 toInterval' = toInterval center
             return (either toInterval' id x,
                     either toInterval' id y)
@@ -129,26 +131,18 @@ square = moduleWithoutSuite "square" $ do
                 `defaultTo` False
             let (x,y) = either (\w -> (w,w)) id size
             return (toInterval center x, toInterval center y)
-
-    r      :: ℝ    <- argument "r"
-                        `doc` "radius of rounding"
-                        `defaultTo` 0
-
     -- Tests
     test "square(2);"
         `eulerCharacteristic` 0
     test "square(size=[2,3]);"
         `eulerCharacteristic` 0
-
     addObj2 $ Prim.rectR r (x1, y1) (x2, y2)
 
-cylinder :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+cylinder :: (String, [OVal] -> ArgParser (IO [OVal]))
 cylinder = moduleWithoutSuite "cylinder" $ do
-
     example "cylinder(r=10, h=30, center=true);"
     example "cylinder(r1=4, r2=6, h=10);"
     example "cylinder(r=5, h=10, $fn = 6);"
-
     -- arguments
     r      :: ℝ    <- argument "r"
                 `defaultTo` 1
@@ -162,19 +156,17 @@ cylinder = moduleWithoutSuite "cylinder" $ do
     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,52 +175,39 @@ cylinder = moduleWithoutSuite "cylinder" $ do
             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 :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+circle :: (String, [OVal] -> ArgParser (IO [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     :: ℝ <- argument "r"
+               `doc` "radius of the circle"
+    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
+    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]]]
+            [(r*cos θ, r*sin θ )| θ <- [2*pi*(fromℕtoℝ n)/(fromℕtoℝ sides) | n <- [0 .. sides - 1]]]
 
-polygon :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+polygon :: (String, [OVal] -> ArgParser (IO [OVal]))
 polygon = moduleWithoutSuite "polygon" $ do
-    
     example "polygon ([(0,0), (0,10), (10,0)]);"
-    
-    points :: [ℝ2] <-  argument "points"
+    points :: [ℝ2]  <- argument "points"
                         `doc` "vertices of the polygon"
-    paths :: [ℕ ]  <- argument "paths"
+    paths  :: [ℕ]   <- argument "paths"
                         `doc` "order to go through vertices; ignored for now"
                         `defaultTo` []
     r      :: ℝ     <- argument "r"
@@ -238,8 +217,7 @@ polygon = moduleWithoutSuite "polygon" $ do
         [] -> addObj2 $ Prim.polygonR r points
         _ -> return $ return []
 
-
-union :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+union :: (String, [OVal] -> ArgParser (IO [OVal]))
 union = moduleWithSuite "union" $ \children -> do
     r :: ℝ <- argument "r"
         `defaultTo` 0.0
@@ -248,7 +226,7 @@ union = moduleWithSuite "union" $ \children -> do
         then objReduce (Prim.unionR r) (Prim.unionR r) children
         else objReduce  Prim.union      Prim.union     children
 
-intersect :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+intersect :: (String, [OVal] -> ArgParser (IO [OVal]))
 intersect = moduleWithSuite "intersection" $ \children -> do
     r :: ℝ <- argument "r"
         `defaultTo` 0.0
@@ -257,7 +235,7 @@ intersect = moduleWithSuite "intersection" $ \children -> do
         then objReduce (Prim.intersectR r) (Prim.intersectR r) children
         else objReduce  Prim.intersect      Prim.intersect     children
 
-difference :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+difference :: (String, [OVal] -> ArgParser (IO [OVal]))
 difference = moduleWithSuite "difference" $ \children -> do
     r :: ℝ <- argument "r"
         `defaultTo` 0.0
@@ -266,12 +244,10 @@ difference = moduleWithSuite "difference" $ \children -> do
         then objReduce (Prim.differenceR r) (Prim.differenceR r) children
         else objReduce  Prim.difference      Prim.difference     children
 
-translate :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+translate :: (String, [OVal] -> ArgParser (IO [OVal]))
 translate = moduleWithSuite "translate" $ \children -> do
-
     example "translate ([2,3]) circle (4);"
     example "translate ([5,6,7]) sphere(5);"
-
     (x,y,z) <-
         do
             x :: ℝ <- argument "x"
@@ -289,7 +265,6 @@ translate = moduleWithSuite "translate" $ \children -> do
                 Left          x       -> (x,0,0)
                 Right (Left  (x,y)  ) -> (x,y,0)
                 Right (Right (x,y,z)) -> (x,y,z)
-    
     return $ return $
         objMap (Prim.translate (x,y)) (Prim.translate (x,y,z)) children
 
@@ -297,13 +272,13 @@ deg2rad :: ℝ -> ℝ
 deg2rad x = x / 180.0 * pi
 
 -- This is mostly insane
-rotate :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+rotate :: (String, [OVal] -> ArgParser (IO [OVal]))
 rotate = moduleWithSuite "rotate" $ \children -> do
     a <- argument "a"
         `doc` "value to rotate by; angle or list of angles"
-    v <- argument "v" `defaultTo` (0, 0, 1)
+    v <- argument "v"
+        `defaultTo` (0, 0, 1)
         `doc` "Vector to rotate around if a is a single angle"
-
     -- caseOType matches depending on whether size can be coerced into
     -- the right object. See Graphics.Implicit.ExtOpenScad.Util
     -- Entries must be joined with the operator <||>
@@ -317,30 +292,25 @@ rotate = moduleWithSuite "rotate" $ \children -> do
             objMap id (Prim.rotate3 (deg2rad yz, deg2rad zx, 0)) children
         ) <||> const []
 
-scale :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+scale :: (String, [OVal] -> ArgParser (IO [OVal]))
 scale = moduleWithSuite "scale" $ \children -> do
-
     example "scale(2) square(5);"
     example "scale([2,3]) square(5);"
     example "scale([2,3,4]) cube(5);"
-
-    v :: Either ℝ (Either ℝ2 ℝ3) <- argument "v"
+    v <- argument "v"
         `doc` "vector or scalar to scale by"
-    
     let
         scaleObjs stretch2 stretch3 =
             objMap (Prim.scale stretch2) (Prim.scale stretch3) children
-    
     return $ return $ case v of
         Left   x              -> scaleObjs (x,1) (x,1,1)
         Right (Left (x,y))    -> scaleObjs (x,y) (x,y,1)
         Right (Right (x,y,z)) -> scaleObjs (x,y) (x,y,z)
 
-extrude :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+extrude :: (String, [OVal] -> ArgParser (IO [OVal]))
 extrude = moduleWithSuite "linear_extrude" $ \children -> do
     example "linear_extrude(10) square(5);"
-
-    height :: Either ℝ (ℝ -> ℝ -> ℝ) <- argument "height" `defaultTo` (Left 1)
+    height :: Either ℝ (ℝ -> ℝ -> ℝ) <- argument "height" `defaultTo` Left 1
         `doc` "height to extrude to..."
     center :: Bool <- argument "center" `defaultTo` False
         `doc` "center? (the z component)"
@@ -352,7 +322,6 @@ extrude = moduleWithSuite "linear_extrude" $ \children -> do
         `doc` "translate according to this funciton as we extrude..."
     r      :: ℝ   <- argument "r"      `defaultTo` 0
         `doc` "round the top?"
-    
     let
         heightn = case height of
                 Left  h -> h
@@ -361,21 +330,17 @@ extrude = moduleWithSuite "linear_extrude" $ \children -> do
         height' = case height of
             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 :: (VectorSpace a, s ~ (Scalar a), s ~ ℝ) => Either a (ℝ -> a) -> ℝ -> a
+        funcify (Left val) h = (h/heightn) *^ val
         funcify (Right f ) h = f h
-        
         twist' = fmap funcify twist
         scale' = fmap funcify scaleArg
         translate' = fmap funcify translateArg
-    
     return $ return $ obj2UpMap (
         \obj -> case height of
             Left constHeight | isNothing twist && isNothing scaleArg && isNothing translateArg ->
@@ -384,55 +349,50 @@ extrude = moduleWithSuite "linear_extrude" $ \children -> do
                 shiftAsNeeded $ Prim.extrudeRM r twist' scale' translate' obj height'
         ) children
 
-rotateExtrude :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+rotateExtrude :: (String, [OVal] -> ArgParser (IO [OVal]))
 rotateExtrude = moduleWithSuite "rotate_extrude" $ \children -> do
     example "rotate_extrude() translate(20) circle(10);"
-
-    totalRot :: ℝ <- argument "a" `defaultTo` 360
-        `doc` "angle to sweep"
+    totalRot     :: ℝ <- argument "a" `defaultTo` 360
+                    `doc` "angle to sweep"
     r            :: ℝ    <- argument "r"   `defaultTo` 0
     translateArg :: Either ℝ2 (ℝ -> ℝ2) <- argument "translate" `defaultTo` Left (0,0)
     rotateArg    :: Either ℝ  (ℝ -> ℝ ) <- argument "rotate" `defaultTo` Left 0
-
     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
+            || 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 :: (String, [OVal] -> ArgParser (IO [OVal]))
+rotateExtrudeStatement = moduleWithSuite "rotate_extrude" $ \suite -> do
+    -- arguments
+    h :: ℝ <- realArgument "h"
+    center :: Bool <- boolArgumentWithDefault "center" False
+    twist :: ℝ <- realArgumentWithDefault 0.0
+    r :: ℝ <- realArgumentWithDefault "r" 0.0
 
-
-{-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)
 -}
 
-shell :: ([Char], [OVal] -> ArgParser (IO [OVal]))
-shell = moduleWithSuite "shell" $ \children-> do
+shell :: (String, [OVal] -> ArgParser (IO [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 :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+-- Not a permanent solution! Breaks if can't pack.
+pack :: (String, [OVal] -> ArgParser (IO [OVal]))
 pack = moduleWithSuite "pack" $ \children -> do
-
     example "pack ([45,45], sep=2) { circle(10); circle(10); circle(10); circle(10); }"
-
     -- 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 $
         let (obj2s, obj3s, others) = divideObjs children
@@ -448,17 +408,14 @@ pack = moduleWithSuite "pack" $ \children -> do
                     putStrLn "Can't pack given objects in given box with present algorithm"
                     return children
 
-unit :: ([Char], [OVal] -> ArgParser (IO [OVal]))
+unit :: (String, [OVal] -> ArgParser (IO [OVal]))
 unit = moduleWithSuite "unit" $ \children -> do
-
     example "unit(\"inch\") {..}"
-
     -- arguments
-    unitName :: String <- argument "unit"
+    name :: String <- argument "unit"
         `doc` "the unit you wish to work in"
-
     let
-        mmRatio :: Fractional a => [Char] -> Maybe a
+        mmRatio :: String -> Maybe ℝ
         mmRatio "inch" = Just 25.4
         mmRatio "in"   = mmRatio "inch"
         mmRatio "foot" = Just 304.8
@@ -474,32 +431,30 @@ unit = moduleWithSuite "unit" $ \children -> do
         mmRatio "um"   = mmRatio "µm"
         mmRatio "nm"   = Just 0.0000001
         mmRatio _      = Nothing
-
     -- The actual work...
-    return $ case mmRatio unitName of
+    return $ case mmRatio name of
         Nothing -> do
-            putStrLn $ "unrecognized unit " ++ unitName
+            putStrLn $ "unrecognized unit " ++ name
             return children
         Just r  ->
             return $ objMap (Prim.scale (r,r)) (Prim.scale (r,r,r)) children
 
-
 ---------------
 
 (<|>) :: 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)
 
-addObj3 :: SymbolicObj3 -> ArgParser (IO [OVal])
-addObj3 x = return $ return [OObj3 x]
-
 addObj2 :: SymbolicObj2 -> ArgParser (IO [OVal])
 addObj2 x = return $ return [OObj2 x]
 
+addObj3 :: SymbolicObj3 -> ArgParser (IO [OVal])
+addObj3 x = return $ return [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
@@ -520,7 +475,7 @@ obj2UpMap obj2upmod (x:xs) = case x of
     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

@@ -8,20 +8,31 @@
 -- FIXME: why is this required?
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Graphics.Implicit.ExtOpenScad.Util.ArgParser where
+module Graphics.Implicit.ExtOpenScad.Util.ArgParser (argument, doc, defaultTo, example, test, eulerCharacteristic, argMap) where
 
-import Prelude(String, Maybe(Just, Nothing), Int, ($), (++), concat, show, error, return, map, snd, filter, (.), fst, foldl1, not, null, (&&))
+-- imported twice, once qualified. null from Data.Map conflicts with null from Prelude.
+import Prelude(String, Maybe(Just, Nothing), ($), (++), concat, show, error, return, map, snd, filter, (.), fst, foldl1, not, (&&))
+import qualified Prelude as Prelude (null)
 
 import Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch, APTerminator, APFailIf, APExample), OVal (OError), TestInvariant(EulerCharacteristic))
+
 import Graphics.Implicit.ExtOpenScad.Util.OVal (fromOObj, toOObj, OTypeMirror)
 
-import qualified Data.Map as Map
+import Graphics.Implicit.Definitions(ℕ)
+
+-- imported twice, once qualified. null from Data.Map conflicts with null from Prelude.
+import Data.Map (fromList, Map, lookup, delete)
+import qualified Data.Map as Map (null)
+
 import Data.Maybe (isNothing, fromJust, isJust)
 
+import Control.Arrow(first)
+
 -- * ArgParser building functions
 
 -- ** argument and combinators
 
+-- | Builds an argparser for the type that is expected from it.
 argument :: forall desiredType. (OTypeMirror desiredType) => String -> ArgParser desiredType
 argument name =
     AP name Nothing "" $ \oObjVal -> do
@@ -34,6 +45,7 @@ argument name =
                 _   ->  "arg " ++ show oObjVal ++ " not compatible with " ++ name
         -- Using /= Nothing would require Eq desiredType
         APFailIf (isNothing val) errmsg $ APTerminator $ fromJust val
+{-# INLINABLE argument #-}
 
 doc :: forall a. ArgParser a -> String -> ArgParser a
 doc (AP name defMaybeVal _ next) newDoc = AP name defMaybeVal newDoc next
@@ -54,9 +66,9 @@ example str = APExample str (return ())
 test :: String -> ArgParser ()
 test str = APTest str [] (return ())
 
-eulerCharacteristic :: ArgParser a -> Int -> ArgParser a
+eulerCharacteristic :: ArgParser a -> ℕ -> ArgParser a
 eulerCharacteristic (APTest str tests child) χ =
-    APTest str ((EulerCharacteristic χ) : tests) child
+    APTest str (EulerCharacteristic χ : tests) child
 eulerCharacteristic _ _ = error "Impossible!"
 
 -- * Tools for handeling ArgParsers
@@ -64,16 +76,16 @@ eulerCharacteristic _ _ = error "Impossible!"
 -- | Apply arguments to an ArgParser
 
 argMap ::
-    [(Maybe String,  OVal)]      -- ^ arguments
+    [(Maybe String, OVal)]      -- ^ arguments
     -> ArgParser a              -- ^ ArgParser to apply them to
     -> (Maybe a, [String])      -- ^ (result, error messages)
 
-argMap args = argMap2 unnamedArgs (Map.fromList namedArgs) where
+argMap args = argMap2 unnamedArgs (fromList namedArgs) where
     unnamedArgs = map snd $ filter (isNothing . fst) args
-    namedArgs   = map (\(a,b) -> (fromJust a, b)) $ filter (isJust . fst) args
+    namedArgs   = map (first fromJust) $ filter (isJust . fst) args
 
 
-argMap2 :: [OVal] -> Map.Map String OVal -> ArgParser a -> (Maybe a, [String])
+argMap2 :: [OVal] -> Map String OVal -> ArgParser a -> (Maybe a, [String])
 
 argMap2 uArgs nArgs (APBranch branches) =
     foldl1 merge solutions where
@@ -85,10 +97,10 @@ argMap2 uArgs nArgs (APBranch branches) =
         merge (Nothing, _)  a = a
 
 argMap2 unnamedArgs namedArgs (AP name fallback _ f) =
-    case Map.lookup name namedArgs of
+    case lookup name namedArgs of
         Just a -> argMap2
             unnamedArgs
-            (Map.delete name namedArgs)
+            (delete name namedArgs)
             (f a)
         Nothing -> case unnamedArgs of
             x:xs -> argMap2 xs namedArgs (f x)
@@ -97,11 +109,7 @@ argMap2 unnamedArgs namedArgs (AP name fallback _ f) =
                 Nothing -> (Nothing, ["No value and no default for argument " ++ name])
 
 argMap2 a b (APTerminator val) =
-    (Just val,
-        if not (null a && Map.null b)
-        then ["unused arguments"]
-        else []
-    )
+    (Just val, ["unused arguments" | not (Prelude.null a && Map.null b)])
 
 argMap2 a b (APFailIf testval err child) =
     if testval

Graphics/Implicit/ExtOpenScad/Util/OVal.hs

@@ -3,112 +3,119 @@
 -- Released under the GNU AGPLV3+, see LICENSE
 
 -- FIXME: required. why?
-{-# LANGUAGE ViewPatterns, RankNTypes, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
-{-# LANGUAGE CPP #-}
-#if __GLASGOW_HASKELL__ < 710
-{-# LANGUAGE OverlappingInstances #-}
-#endif
+module Graphics.Implicit.ExtOpenScad.Util.OVal(OTypeMirror, (<||>), fromOObj, toOObj, divideObjs, caseOType, oTypeStr, getErrors) where
 
-module Graphics.Implicit.ExtOpenScad.Util.OVal where
+import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left,Right), Char, String, (==), fromInteger, floor, ($), (.), map, error, (++), show, head, flip, filter, not, return, head)
 
-import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left,Right), String, Char, (==), fromInteger, floor, ($), (.), map, error, (++), show, fromIntegral, head, flip, filter, not, return)
+import Graphics.Implicit.Definitions(ℝ, ℕ, SymbolicObj2, SymbolicObj3, fromℕtoℝ)
 
-import Graphics.Implicit.Definitions(ℝ, ℕ, SymbolicObj2, SymbolicObj3)
 import Graphics.Implicit.ExtOpenScad.Definitions (OVal(ONum, OBool, OString, OList, OFunc, OUndefined, OModule, OError, OObj2, OObj3))
-import qualified Control.Monad as Monad
-import Data.Maybe (fromJust, isJust)
+
+import Control.Monad (mapM, msum)
+
+import Data.Maybe (fromMaybe, maybe)
 
 -- for some minimal paralellism.
 import Control.Parallel.Strategies(runEval, rpar, rseq)
 
--- | We'd like to be able to turn OVals into a given Haskell type
+-- Convert OVals (and Lists of OVals) into a given Haskell type
 class OTypeMirror a where
     fromOObj :: OVal -> Maybe a
+    fromOObjList :: OVal -> Maybe [a]
+    fromOObjList (OList list) = mapM fromOObj list
+    fromOObjList _ = Nothing
+    {-# INLINABLE fromOObjList #-}
     toOObj :: a -> OVal
 
 instance OTypeMirror OVal where
-    fromOObj a = Just a
+    fromOObj = Just
     toOObj a = a
 
 instance OTypeMirror ℝ where
     fromOObj (ONum n) = Just n
     fromOObj _ = Nothing
-    toOObj n = ONum n
+    {-# INLINABLE fromOObj #-}
+    toOObj = ONum
 
 instance OTypeMirror ℕ where
     fromOObj (ONum n) = if n == fromInteger (floor n) then Just (floor n) else Nothing
     fromOObj _ = Nothing
-    toOObj n = ONum $ fromIntegral n
+    {-# INLINABLE fromOObj #-}
+    toOObj = ONum . fromℕtoℝ
 
 instance OTypeMirror Bool where
     fromOObj (OBool b) = Just b
     fromOObj _ = Nothing
-    toOObj b = OBool b
+    {-# INLINABLE fromOObj #-}
+    toOObj = OBool
 
-#if __GLASGOW_HASKELL__ >= 710
-instance {-# Overlapping #-} OTypeMirror String where
-#else
-instance OTypeMirror String where
-#endif
-    fromOObj (OString str) = Just str
+-- We don't actually use single chars, this is to compile lists of chars (AKA strings) after passing through OTypeMirror [a]'s fromOObj.
+-- This lets us handle strings without overlapping the [a] case.
+instance OTypeMirror Char where
+    fromOObj (OString str) = Just $ head str
     fromOObj _ = Nothing
-    toOObj str = OString str
+    {-# INLINABLE fromOObj #-}
+    fromOObjList (OString str) = Just str
+    fromOObjList _ = Nothing
+    toOObj a = OString [a]
 
-instance forall a. (OTypeMirror a) => OTypeMirror (Maybe a) where
+instance (OTypeMirror a) => OTypeMirror [a] where
+    fromOObj = fromOObjList
+    {-# INLINABLE fromOObj #-}
+    toOObj list = OList $ map toOObj list
+
+instance (OTypeMirror a) => OTypeMirror (Maybe a) where
     fromOObj a = Just $ fromOObj a
+    {-# INLINABLE fromOObj #-}
     toOObj (Just a) = toOObj a
     toOObj Nothing  = OUndefined
 
-#if __GLASGOW_HASKELL__ >= 710
-instance {-# Overlappable #-} forall a. (OTypeMirror a) => OTypeMirror [a] where
-#else
-instance forall a. (OTypeMirror a) => OTypeMirror [a] where
-#endif
-    fromOObj (OList list) = Monad.sequence . map fromOObj $ list
-    fromOObj _ = Nothing
-    toOObj list = OList $ map toOObj list
-
-instance forall a b. (OTypeMirror a, OTypeMirror b) => OTypeMirror (a,b) where
-    fromOObj (OList ((fromOObj -> Just a):(fromOObj -> Just b):[])) = Just (a,b)
+instance (OTypeMirror a, OTypeMirror b) => OTypeMirror (a,b) where
+    fromOObj (OList [fromOObj -> Just a,fromOObj -> Just b]) = Just (a,b)
     fromOObj _ = Nothing
+    {-# INLINABLE fromOObj #-}
     toOObj (a,b) = OList [toOObj a, toOObj b]
 
-
-instance forall a b c. (OTypeMirror a, OTypeMirror b, OTypeMirror c) => OTypeMirror (a,b,c) where
-    fromOObj (OList ((fromOObj -> Just a):(fromOObj -> Just b):(fromOObj -> Just c):[])) =
+instance (OTypeMirror a, OTypeMirror b, OTypeMirror c) => OTypeMirror (a,b,c) where
+    fromOObj (OList [fromOObj -> Just a,fromOObj -> Just b,fromOObj -> Just c]) =
         Just (a,b,c)
     fromOObj _ = Nothing
+    {-# INLINABLE fromOObj #-}
     toOObj (a,b,c) = OList [toOObj a, toOObj b, toOObj c]
 
-instance forall a b. (OTypeMirror a, OTypeMirror b) => OTypeMirror (a -> b) where
+instance (OTypeMirror a, OTypeMirror b) => OTypeMirror (a -> b) where
     fromOObj (OFunc f) =  Just $ \input ->
         let
             oInput = toOObj input
             oOutput = f oInput
             output :: Maybe b
             output = fromOObj oOutput
-        in case output of
-            Just out -> out
-            Nothing -> error $ "coercing OVal to a -> b isn't always safe; use a -> Maybe b"
-                            ++ " (trace: " ++ show oInput ++ " -> " ++ show oOutput ++ " )"
+        in
+          fromMaybe (error $ "coercing OVal to a -> b isn't always safe; use a -> Maybe b"
+                               ++ " (trace: " ++ show oInput ++ " -> " ++ show oOutput ++ " )") output
     fromOObj _ = Nothing
+    {-# INLINABLE fromOObj #-}
     toOObj f = OFunc $ \oObj ->
         case fromOObj oObj :: Maybe a of
             Nothing  -> OError ["bad input type"]
             Just obj -> toOObj $ f obj
 
-
-instance forall a b. (OTypeMirror a, OTypeMirror b) => OTypeMirror (Either a b) where
+instance (OTypeMirror a, OTypeMirror b) => OTypeMirror (Either a b) where
     fromOObj (fromOObj -> Just (x :: a)) = Just $ Left  x
     fromOObj (fromOObj -> Just (x :: b)) = Just $ Right x
     fromOObj _ = Nothing
+    {-# INLINABLE fromOObj #-}
 
     toOObj (Right x) = toOObj x
     toOObj (Left  x) = toOObj x
 
-oTypeStr :: OVal -> [Char]
-oTypeStr (OUndefined) = "Undefined"
+-- A string representing each type.
+oTypeStr :: OVal -> String
+oTypeStr OUndefined = "Undefined"
 oTypeStr (OBool   _ ) = "Bool"
 oTypeStr (ONum    _ ) = "Number"
 oTypeStr (OList   _ ) = "List"
@@ -121,7 +128,7 @@ oTypeStr (OObj3   _ ) = "3D Object"
 
 getErrors :: OVal -> Maybe String
 getErrors (OError er) = Just $ head er
-getErrors (OList l)   = Monad.msum $ map getErrors l
+getErrors (OList l)   = msum $ map getErrors l
 getErrors _           = Nothing
 
 caseOType :: forall c a. a -> (a -> c) -> c
@@ -132,21 +139,20 @@ infixr 2 <||>
     => (desiredType -> out)
     -> (OVal -> out)
     -> (OVal -> out)
-(<||>) f g = \input ->
+(<||>) f g input =
     let
         coerceAttempt :: Maybe desiredType
         coerceAttempt = fromOObj input
     in
-        if isJust coerceAttempt -- ≅ (/= Nothing) but no Eq req
-        then f $ fromJust coerceAttempt
-        else g input
+        maybe (g input) f coerceAttempt
 
+-- separate 2d and 3d objects from a set of OVals.
 divideObjs :: [OVal] -> ([SymbolicObj2], [SymbolicObj3], [OVal])
 divideObjs children =
     runEval $ do
-    obj2s <- rseq ([ x | OObj2 x <- children ])
-    obj3s <- rseq ([ x | OObj3 x <- children ])
-    objs <- rpar (filter (not . isOObj) $ children )
+    obj2s <- rseq [ x | OObj2 x <- children ]
+    obj3s <- rseq [ x | OObj3 x <- children ]
+    objs <- rpar (filter (not . isOObj) children)
     return (obj2s, obj3s, objs)
         where
           isOObj  (OObj2 _) = True

Graphics/Implicit/ExtOpenScad/Util/StateC.hs

@@ -7,58 +7,63 @@
 
 -- FIXME: required. why?
 {-# LANGUAGE KindSignatures, FlexibleContexts #-}
-{-# LANGUAGE ViewPatterns, RankNTypes, ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
 
-module Graphics.Implicit.ExtOpenScad.Util.StateC (getVarLookup, modifyVarLookup, lookupVar, pushVals, getVals, putVals, withPathShiftedBy, getPath, getRelPath, errorC, mapMaybeM, StateC) where
+module Graphics.Implicit.ExtOpenScad.Util.StateC (getVarLookup, modifyVarLookup, lookupVar, pushVals, getVals, putVals, withPathShiftedBy, getPath, getRelPath, errorC, mapMaybeM, StateC, CompState(CompState)) where
 
-import Prelude(FilePath, IO, String, Maybe(Just, Nothing), Show, Char, Monad, fmap, (.), ($), (++), return, putStrLn, show)
+import Prelude(FilePath, IO, String, Maybe(Just, Nothing), Show, Monad, fmap, (.), ($), (++), return, putStrLn, show)
 
 import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup, OVal)
 
-import qualified Data.Map as Map
+import Data.Map (lookup)
 import Control.Monad.State (StateT, get, put, modify, liftIO)
 import System.FilePath((</>))
 import Control.Monad.IO.Class (MonadIO)
+import Data.Kind (Type)
+
+-- | This is the state of a computation. It contains a hash of variables, an array of OVals, and a path.
+newtype CompState = CompState (VarLookup, [OVal], FilePath)
 
-type CompState = (VarLookup, [OVal], FilePath, (), ())
 type StateC = StateT CompState IO
 
 getVarLookup :: StateC VarLookup
-getVarLookup = fmap (\(a,_,_,_,_) -> a) get
+getVarLookup = fmap (\(CompState (a,_,_)) -> a) get
 
 modifyVarLookup :: (VarLookup -> VarLookup) -> StateC ()
-modifyVarLookup = modify . (\f (a,b,c,d,e) -> (f a, b, c, d, e))
+modifyVarLookup = modify . (\f (CompState (a,b,c)) -> CompState (f a, b, c))
 
+-- | Perform a variable lookup
 lookupVar :: String -> StateC (Maybe OVal)
 lookupVar name = do
     varlookup <- getVarLookup
-    return $ Map.lookup name varlookup
+    return $ lookup name varlookup
 
 pushVals :: [OVal] -> StateC ()
-pushVals vals = modify (\(a,b,c,d,e) -> (a, vals ++ b,c,d,e))
+pushVals vals = modify (\(CompState (a,b,c)) -> CompState (a, vals ++ b, c))
 
 getVals :: StateC [OVal]
 getVals = do
-    (_,b,_,_,_) <- get
+    (CompState (_,b,_)) <- get
     return b
 
 putVals :: [OVal] -> StateC ()
 putVals vals = do
-    (a,_,c,d,e) <- get
-    put (a,vals,c,d,e)
+    (CompState (a,_,c)) <- get
+    put $ CompState (a,vals,c)
 
 withPathShiftedBy :: FilePath -> StateC a -> StateC a
 withPathShiftedBy pathShift s = do
-    (a,b,path,d,e) <- get
-    put (a,b, path </> pathShift, d, e)
+    (CompState (a,b,path)) <- get
+    put $ CompState (a, b, path </> pathShift)
     x <- s
-    (a',b',_,d',e') <- get
-    put (a', b', path, d', e')
+    (CompState (a',b',_)) <- get
+    put $ CompState (a', b', path)
     return x
 
+-- | Return the path stored in the state.
 getPath :: StateC FilePath
 getPath = do
-    (_,_,c,_,_) <- get
+    (CompState (_,_,c)) <- get
     return c
 
 getRelPath :: FilePath -> StateC FilePath
@@ -66,10 +71,11 @@ getRelPath relPath = do
     path <- getPath
     return $ path </> relPath
 
-errorC :: forall (m :: * -> *) a. (Show a, MonadIO m) => a -> [Char] -> m ()
-errorC lineN err = liftIO $ putStrLn $ "At " ++ show lineN ++ ": " ++ err
+errorC :: forall (m :: Type -> Type) a. (Show a, MonadIO m) => a -> a -> String -> m ()
+errorC lineN columnN err = liftIO $ putStrLn $ "On line " ++ show lineN ++ ", column " ++ show columnN ++ ": " ++ err
+{-# INLINABLE errorC #-}
 
-mapMaybeM :: forall t (m :: * -> *) a. Monad m => (t -> m a) -> Maybe t -> m (Maybe a)
+mapMaybeM :: forall t (m :: Type -> Type) a. Monad m => (t -> m a) -> Maybe t -> m (Maybe a)
 mapMaybeM f (Just a) = do
     b <- f a
     return (Just b)

Graphics/Implicit/FastIntUtil.hs

@@ -0,0 +1,79 @@
+-- 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
+
+module Graphics.Implicit.FastIntUtil (Fastℕ(Fastℕ), toFastℕ, fromFastℕ) where
+
+import Prelude (Integral(toInteger, quot, rem, quotRem, div, mod, divMod), Num((+), (*), abs, negate, signum, fromInteger), Eq, Ord, Enum(succ, pred, toEnum, fromEnum), Real(toRational), Show, ($), Read, Int)
+
+import qualified Prelude as P ((+), (*), abs, negate, signum, fromInteger, succ, pred, toEnum, quotRem, divMod, toInteger)
+
+import GHC.Real (Ratio((:%)))
+
+class FastN n where
+  fromFastℕ :: Fastℕ -> n
+  toFastℕ :: n -> Fastℕ
+
+instance FastN Int where
+  fromFastℕ (Fastℕ a) = a
+  {-# INLINABLE fromFastℕ #-}
+  toFastℕ a = Fastℕ a
+  {-# INLINABLE toFastℕ #-}
+
+instance FastN Fastℕ where
+  fromFastℕ (Fastℕ a) = Fastℕ a
+  {-# INLINABLE fromFastℕ #-}
+  toFastℕ a = a
+  {-# 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)
+
+instance Real Fastℕ where
+  toRational (Fastℕ a) = P.toInteger a :% 1
+  {-# INLINABLE toRational #-}
+
+fastℕBoth :: (Int, Int) -> (Fastℕ, Fastℕ)
+fastℕBoth (a, b) = (Fastℕ a, Fastℕ b)
+{-# INLINABLE fastℕBoth #-}
+
+instance Integral Fastℕ where
+  toInteger (Fastℕ a)         = P.toInteger a
+  {-# INLINABLE toInteger #-}
+  quot (Fastℕ n) (Fastℕ d)    = Fastℕ $ q where (q,_) = quotRem n d
+  {-# INLINABLE quot #-}
+  rem (Fastℕ n) (Fastℕ d)     = Fastℕ $ r where (_,r) = quotRem n d
+  {-# INLINABLE rem #-}
+  quotRem (Fastℕ a) (Fastℕ b) = fastℕBoth $ P.quotRem a b
+  {-# INLINABLE quotRem #-}
+  div (Fastℕ n) (Fastℕ d)     = Fastℕ $ q where (q,_) = divMod n d
+  {-# INLINABLE div #-}
+  mod (Fastℕ n) (Fastℕ d)     = Fastℕ $ r where (_,r) = divMod n d
+  {-# INLINABLE mod #-}
+  divMod (Fastℕ n) (Fastℕ d)  = fastℕBoth $ P.divMod n d
+  {-# INLINABLE divMod #-}
+
+instance Num Fastℕ where
+  (+) (Fastℕ a) (Fastℕ b) = Fastℕ $ a P.+ b
+  {-# INLINABLE (+) #-}
+  (*) (Fastℕ a) (Fastℕ b) = Fastℕ $ a P.* b
+  {-# INLINABLE (*) #-}
+  abs (Fastℕ a)           = Fastℕ $ P.abs a
+  {-# INLINABLE abs #-}
+  negate (Fastℕ a)        = Fastℕ $ P.negate a
+  {-# INLINABLE negate #-}
+  signum (Fastℕ a)        = Fastℕ $ P.signum a
+  {-# INLINABLE signum #-}
+  fromInteger a           = Fastℕ $ P.fromInteger a
+  {-# INLINABLE fromInteger #-}
+
+instance Enum Fastℕ where
+  succ (Fastℕ x)     = Fastℕ $ P.succ x
+  {-# INLINABLE succ #-}
+  pred (Fastℕ x)     = Fastℕ $ P.pred x
+  {-# INLINABLE pred #-}
+  toEnum           n = Fastℕ $ P.toEnum n
+  {-# INLINABLE toEnum #-}
+  fromEnum (Fastℕ n) = n
+  {-# INLINABLE fromEnum #-}

Graphics/Implicit/IntegralUtil.hs

@@ -0,0 +1,97 @@
+-- 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
+
+-- Allow us to use explicit foralls when writing function type declarations.
+{-# LANGUAGE ExplicitForAll #-}
+
+module Graphics.Implicit.IntegralUtil (ℕ, toℕ, fromℕ) where
+
+import Prelude (Integral(toInteger, quot, rem, quotRem, div, mod, divMod), Num((+), (*), abs, negate, signum, fromInteger), Eq, Ord, Enum(succ, pred, toEnum, fromEnum), Real(toRational), Show, ($), Read, fromIntegral, Int, Integer)
+
+import qualified Prelude as P ((+), (*), abs, negate, signum, succ, pred, toEnum, fromEnum, quotRem, divMod)
+
+import GHC.Real (Ratio((:%)))
+
+-- 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ℕ a = ℕ a
+  {-# INLINABLE toℕ #-}
+
+instance N Fastℕ where
+  fromℕ (ℕ a) = Fastℕ $ fromIntegral a
+  {-# INLINABLE fromℕ #-}
+  toℕ a = ℕ $ fromIntegral a
+  {-# INLINABLE toℕ #-}
+
+instance N Int where
+  fromℕ (ℕ a) = fromIntegral a
+  {-# INLINABLE fromℕ #-}
+  toℕ a = ℕ $ fromIntegral a
+  {-# INLINABLE toℕ #-}
+
+-- Arbitrary precision integers. To be used for anything countable, or in ratios.
+newtype ℕ = ℕ Integer
+  deriving (Show, Read, Eq, Ord)
+
+instance Real ℕ where
+  toRational (ℕ a) = a :% 1
+  {-# INLINABLE toRational #-}
+
+bothℕ :: (Integer, Integer) -> (ℕ, ℕ)
+bothℕ (a, b) = (ℕ a , ℕ b)
+
+instance Integral ℕ where
+  toInteger (ℕ a)     = a
+  {-# INLINABLE toInteger #-}
+  quot (ℕ n) (ℕ d)    = ℕ $ q where (q,_) = quotRem n d
+  {-# INLINABLE quot #-}
+  rem (ℕ n) (ℕ d)     = ℕ $ r where (_,r) = quotRem n d
+  {-# INLINABLE rem #-}
+  quotRem (ℕ a) (ℕ b) = bothℕ $ P.quotRem a b 
+  {-# INLINABLE quotRem #-}
+  div (ℕ n) (ℕ d)     = ℕ $ q where (q,_) = divMod n d
+  {-# INLINABLE div #-}
+  mod (ℕ n) (ℕ d)     = ℕ $ r where (_,r) = divMod n d
+  {-# INLINABLE mod #-}
+  divMod (ℕ n) (ℕ d)  = bothℕ $ P.divMod n d
+  {-# INLINABLE divMod #-}
+
+instance Num ℕ where
+  (+) (ℕ a) (ℕ b) = ℕ $ a P.+ b
+  {-# INLINABLE (+) #-}
+  (*) (ℕ a) (ℕ b) = ℕ $ a P.* b
+  {-# INLINABLE (*) #-}
+  abs (ℕ a)       = ℕ $ P.abs a
+  {-# INLINABLE abs #-}
+  negate (ℕ a)    = ℕ $ P.negate a
+  {-# INLINABLE negate #-}
+  signum (ℕ a)    = ℕ $ P.signum a
+  {-# INLINABLE signum #-}
+  fromInteger a   = ℕ a
+  {-# INLINABLE fromInteger #-}
+
+-- | Note that we do not implement all of the members of the typeclass here.
+instance Enum ℕ where
+  succ (ℕ x) = ℕ $ P.succ x
+  {-# INLINABLE succ #-}
+  pred (ℕ x) = ℕ $ P.pred x
+  {-# INLINABLE pred #-}
+  toEnum n = ℕ $ P.toEnum n
+  {-# INLINABLE toEnum #-}
+  fromEnum (ℕ n) = P.fromEnum n
+  {-# INLINABLE fromEnum #-}
+  
+
+
+
+

Graphics/Implicit/MathUtil.hs

@@ -9,21 +9,27 @@
 module Graphics.Implicit.MathUtil (rmax, rmaximum, rminimum, distFromLineSeg, pack, box3sWithin) where
 
 -- Explicitly include what we need from Prelude.
-import Prelude (Bool, Num, Ord, Ordering, (>), (<), (+), ($), (/), otherwise, not, (||), (&&), abs, (-), (*), sin, asin, pi, max, sqrt, min, compare, (<=), fst, snd, (++))
+import Prelude (Bool, Num, Ord, Ordering, (>), (<), (+), ($), (/), otherwise, not, (||), (&&), abs, (-), (*), sin, asin, pi, max, sqrt, min, compare, (<=), fst, snd, (++), head, flip)
 
 import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, Box2, (⋅))
 
-import Data.List (sort, sortBy, reverse, (!!))
+import Data.List (sort, sortBy, (!!))
+
 import Data.VectorSpace (magnitude, normalized, (^-^), (^+^), (*^))
-import Data.AffineSpace ((.-.))
+
+-- get the distance between two points.
+import Data.AffineSpace (distance)
 
 -- | The distance a point p is from a line segment (a,b)
 distFromLineSeg :: ℝ2 -> (ℝ2, ℝ2) -> ℝ
-distFromLineSeg p (a,b) = magnitude (closest .-. p)
+distFromLineSeg p (a,b) = distance p closest
     where
         ab = b ^-^ a
         ap = p ^-^ a
-        d  = normalized ab ⋅ ap
+        d :: ℝ
+        d  = (normalized ab) ⋅ ap
+        -- the closest point to p on the line segment.
+        closest :: ℝ2
         closest
             | d < 0 = a
             | d > magnitude ab = b
@@ -70,26 +76,26 @@ rmaximum ::
     ℝ      -- ^ radius
     -> [ℝ] -- ^ numbers to take round maximum
     -> ℝ   -- ^ resulting number
-rmaximum _ (a:[]) = a
-rmaximum r (a:b:[]) = rmax r a b
+rmaximum _ [a] = a
+rmaximum r [a,b] = rmax r a b
 rmaximum r l =
     let
-        tops = reverse $ sort l
+        tops = sortBy (flip compare) l
     in
-        rmax r (tops !! 0) (tops !! 1)
+        rmax r (head tops) (tops !! 1)
 
 -- | Like rmin but on a list.
 rminimum ::
     ℝ      -- ^ radius
     -> [ℝ] -- ^ numbers to take round minimum
     -> ℝ   -- ^ resulting number
-rminimum _ (a:[]) = a
-rminimum r (a:b:[]) = rmin r a b
+rminimum _ [a] = a
+rminimum r [a,b] = rmin r a b
 rminimum r l =
     let
         tops = sort l
     in
-        rmin r (tops !! 0) (tops !! 1)
+        rmin r (head tops) (tops !! 1)
 
 -- | Pack the given objects in a box the given size.
 pack ::
@@ -107,9 +113,9 @@ pack (dx, dy) sep objs = packSome sortedObjs (dx, dy)
             (\(boxa, _) (boxb, _) -> compareBoxesByY boxa boxb )
             objs
 
-        tmap1 :: forall t t1 t2. (t2 -> t) -> (t2, t1) -> (t, t1)
+        tmap1 :: (t2 -> t) -> (t2, t1) -> (t, t1)
         tmap1 f (a,b) = (f a, b)
-        tmap2 :: forall t t1 t2. (t2 -> t1) -> (t, t2) -> (t, t1)
+        tmap2 :: (t2 -> t1) -> (t, t2) -> (t, t1)
         tmap2 f (a,b) = (a, f b)
 
         packSome :: [(Box2,a)] -> Box2 -> ([(ℝ2,a)], [(Box2,a)])
@@ -121,7 +127,7 @@ pack (dx, dy) sep objs = packSome sortedObjs (dx, dy)
                         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

@@ -2,10 +2,11 @@
 -- 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
 
+-- as there is no real content here, we need no content from the prelude.
 import Prelude()
 
 import Graphics.Implicit.ObjectUtil.GetImplicit3 (getImplicit3)

Graphics/Implicit/ObjectUtil/GetBox2.hs

@@ -2,7 +2,12 @@
 -- Copyright 2016, Julia Longtin (julial@turinglace.com)
 -- Released under the GNU AGPLV3+, see LICENSE
 
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
+-- FIXME: Document what these are for.
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Graphics.Implicit.ObjectUtil.GetBox2 (getBox2, getDist2) where
 
@@ -14,12 +19,12 @@ import Graphics.Implicit.Definitions (ℝ, ℝ2, Box2, (⋯*),
 
 import Data.VectorSpace (magnitude, (^-^), (^+^))
 
--- Is a Box2 empty?
--- Really, this checks if it is one dimensional, which is good enough.
+-- | 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 +32,7 @@ pointsBox points =
     in
         ((minimum xs, minimum ys), (maximum xs, maximum ys))
 
+-- | Define a box that fits around the given boxes.
 unionBoxes :: [Box2] -> Box2
 unionBoxes boxes =
     let
@@ -44,9 +50,8 @@ outsetBox r (a,b) =
 getBox2 :: SymbolicObj2 -> Box2
 -- Primitives
 getBox2 (RectR _ a b) = (a,b)
-getBox2 (Circle r ) =  ((-r, -r), (r,r))
-getBox2 (PolygonR _ points) = ((minimum xs, minimum ys), (maximum xs, maximum ys))
-     where (xs, ys) = unzip points
+getBox2 (Circle r) = ((-r, -r), (r,r))
+getBox2 (PolygonR _ points) = pointsBox points
 -- (Rounded) CSG
 getBox2 (Complement2 _) =
     ((-infty, -infty), (infty, infty))
@@ -86,14 +91,13 @@ getBox2 (Scale2 s symbObj) =
 getBox2 (Rotate2 θ symbObj) =
     let
         ((x1,y1), (x2,y2)) = getBox2 symbObj
-        rotate (x,y) = (cos(θ)*x - sin(θ)*y, sin(θ)*x + cos(θ)*y)
+        rotate (x,y) = (x*(cos θ) - y*(sin θ), x*(sin θ) + y*(cos θ))
     in
         pointsBox [ rotate (x1, y1)
                   , rotate (x1, y2)
                   , rotate (x2, y1)
                   , rotate (x2, y2)
                   ]
-
 -- Boundary mods
 getBox2 (Shell2 w symbObj) =
     outsetBox (w/2) $ getBox2 symbObj
@@ -105,20 +109,26 @@ 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
-getDist2 p (Circle r) = magnitude p + r
-getDist2 p (PolygonR r points) =
-    r + maximum [magnitude (p ^-^ p') | p' <- points]
 -- FIXME: write optimized functions for the rest of the SymbObjs.
+-- Fallthrough: use getBox2 to check the distance a box is from the point.
 getDist2 (x,y) symbObj =
     let
         ((x1,y1), (x2,y2)) = getBox2 symbObj
     in
         sqrt (
-              (max (abs (x1 - x)) (abs (x2 - x))) *
-              (max (abs (x1 - x)) (abs (x2 - x))) +
-              (max (abs (y1 - y)) (abs (y2 - y))) *
-              (max (abs (y1 - y)) (abs (y2 - y)))
+              max (abs (x1 - x)) (abs (x2 - x)) *
+              max (abs (x1 - x)) (abs (x2 - x)) +
+              max (abs (y1 - y)) (abs (y2 - y)) *
+              max (abs (y1 - y)) (abs (y2 - y))
              )
 

Graphics/Implicit/ObjectUtil/GetBox3.hs

@@ -4,19 +4,23 @@
 -- Released under the GNU AGPLV3+, see LICENSE
 
 -- FIXME: required. why?
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances #-}
 
 module Graphics.Implicit.ObjectUtil.GetBox3 (getBox3) where
 
-import Prelude(Eq, Bool(False), Fractional, Either (Left, Right), Maybe(Nothing, Just), (==), (||), max, (/), (-), (+), map, unzip, ($), filter, not, (.), unzip3, minimum, maximum, min, sqrt, (>), (&&), head, (*), (<), abs, either, error, const)
+import Prelude(Eq, Bool(False), Fractional, Either (Left, Right), (==), (||), max, (/), (-), (+), map, unzip, ($), filter, not, (.), unzip3, minimum, maximum, min, (>), (&&), head, (*), (<), abs, either, error, const, otherwise, take)
 
-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 Data.Maybe(Maybe(Nothing, Just))
+
+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 Graphics.Implicit.ObjectUtil.GetBox2 (getBox2, getDist2)
 
 import Data.Maybe (fromMaybe)
 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.
+
+-- Test to see whether a Box3 has area.
 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
@@ -29,7 +33,7 @@ outsetBox r (a,b) =
 getBox3 :: SymbolicObj3 -> Box3
 -- Primitives
 getBox3 (Rect3R _ a b) = (a,b)
-getBox3 (Sphere r ) = ((-r, -r, -r), (r,r,r))
+getBox3 (Sphere r) = ((-r, -r, -r), (r,r,r))
 getBox3 (Cylinder h r1 r2) = ( (-r,-r,0), (r,r,h) ) where r = max r1 r2
 -- (Rounded) CSG
 getBox3 (Complement3 _) =
@@ -81,10 +85,17 @@ getBox3 (Scale3 s symbObj) =
         (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,22 +114,25 @@ getBox3 (ExtrudeOnEdgeOf symbObj1 symbObj2) =
         ((bx1,by1),(bx2,by2)) = getBox2 symbObj2
     in
         ((bx1+ax1, by1+ax1, ay1), (bx2+ax2, by2+ax2, ay2))
--- FIXME: magic numbers in range.
+-- FIXME: magic numbers.
 getBox3 (ExtrudeRM _ twist scale translate symbObj eitherh) =
     let
-        range :: [ℝ]
-        range = [0, 0.1 .. 1.0]
+        samples :: Fastℕ
+        samples=11
+        hfuzz :: ℝ
+        hfuzz = 0.2
+        range :: [Fastℕ]
+        range = [0, 1 .. (samples-1)]
         ((x1,y1),(x2,y2)) = getBox2 symbObj
         (dx,dy) = (x2 - x1, y2 - y1)
-        (xrange, yrange) = (map (\s -> x1+s*dx) $ range, map (\s -> y1+s*dy) $ range )
-
+        (xrange, yrange) = ( map (\s -> x1+s*dx/(fromFastℕtoℝ $ samples-1)) $ map fromFastℕtoℝ range, map (\s -> y1+s*dy/(fromFastℕtoℝ $ samples-1)) $ map fromFastℕtoℝ range )
         h = case eitherh of
               Left h' -> h'
-              Right hf -> hmax + 0.2*(hmax-hmin)
+              Right hf -> hmax + hfuzz*(hmax-hmin)
                 where
                     hs = [hf (x,y) | x <- xrange, y <- yrange]
                     (hmin, hmax) = (minimum hs, maximum hs)
-        hrange = map (h*) $ range
+        hrange = map (/(fromFastℕtoℝ $ samples-1)) $ map (h*) $ map fromFastℕtoℝ range
         sval = case scale of
             Nothing -> 1
             Just scale' -> maximum $ map (abs . scale') hrange
@@ -130,7 +144,7 @@ getBox3 (ExtrudeRM _ twist scale translate symbObj eitherh) =
             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
+        (tvalsx, tvalsy) = unzip $ map (translate' . (h*)) hrange
         (tminx, tminy) = (minimum tvalsx, minimum tvalsy)
         (tmaxx, tmaxy) = (maximum tvalsx, maximum tvalsy)
     in
@@ -143,16 +157,28 @@ getBox3 (RotateExtrude _ _ (Left (xshift,yshift)) _ symbObj) =
         r = max x2 (x2 + xshift)
     in
         ((-r, -r, min y1 (y1 + yshift)),(r, r, max y2 (y2 + yshift)))
+-- FIXME: magic numbers.
 getBox3 (RotateExtrude rot _ (Right f) rotate symbObj) =
     let
+        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' = if xmax > 0 then xmax * 1.1 else if xmax < - x1 then 0 else xmax
-        ymax' = ymax + 0.1 * (ymax - ymin)
-        ymin' = ymin - 0.1 * (ymax - ymin)
+        (xrange, yrange) = unzip $ take (fromFastℕ samples) $ map f $ map (step*) $ map fromFastℕtoℝ range
+        xmax = maximum xrange
+        ymax = maximum yrange
+        ymin = minimum yrange
+        xmax' | xmax > 0 = xmax * xfuzz
+              | xmax < - x1 = 0
+              | otherwise = xmax
+        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]
@@ -161,4 +187,4 @@ getBox3 (RotateExtrude rot _ (Right f) rotate symbObj) =
     in
         ((-r, -r, y1 + ymin'),(r, r, y2 + ymax'))
 -- FIXME: add case for ExtrudeRotateR!
-getBox3(ExtrudeRotateR _ _ _ _ ) = error "ExtrudeRotateR implementation incomplete!"
+getBox3 ExtrudeRotateR{} = error "ExtrudeRotateR implementation incomplete!"

Graphics/Implicit/ObjectUtil/GetImplicit2.hs

@@ -10,94 +10,102 @@
 
 module Graphics.Implicit.ObjectUtil.GetImplicit2 (getImplicit2) where
 
-import Prelude(Int, Num, abs, (-), (/), sqrt, (*), (+), (!!), mod, length, map, (<=), (&&), (>=), (||), odd, ($), (>), filter, (<), minimum, (==), maximum, max, cos, sin, head, tail)
+import Prelude(Num, abs, (-), (/), sqrt, (*), (+), mod, length, map, (<=), (&&), (>=), (||), odd, ($), (>), filter, (<), minimum, (==), maximum, max, cos, sin, head, tail, (.))
+
+import Graphics.Implicit.Definitions (ℝ, ℕ, ℝ2, (⋯/), Obj2, SymbolicObj2(RectR, Circle, PolygonR, Complement2, UnionR2, DifferenceR2, IntersectR2, Translate2, Scale2, Rotate2, Shell2, Outset2, EmbedBoxedObj2))
 
-import Graphics.Implicit.Definitions (SymbolicObj2(RectR, Circle, PolygonR, Complement2, UnionR2, DifferenceR2, IntersectR2, Translate2, Scale2, Rotate2, Shell2, Outset2, EmbedBoxedObj2), Obj2, ℝ, ℝ2, (⋯/))
 import Graphics.Implicit.MathUtil (rminimum, rmaximum, distFromLineSeg)
 
 import Data.VectorSpace ((^-^))
-import Data.List (nub)
+import Data.List (nub, genericIndex, genericLength)
 
 getImplicit2 :: SymbolicObj2 -> Obj2
 -- Primitives
-getImplicit2 (RectR r (x1,y1) (x2,y2)) = \(x,y) -> rmaximum r
-    [abs (x-dx/2-x1) - dx/2, abs (y-dy/2-y1) - dy/2]
-        where (dx, dy) = (x2-x1, y2-y1)
-getImplicit2 (Circle r ) =
-    \(x,y) -> sqrt (x * x + y * y) - r
+getImplicit2 (RectR r (x1,y1) (x2,y2)) =
+    \(x,y) -> let
+         (dx, dy) = (x2-x1, y2-y1)
+    in
+         if r == 0
+         then maximum [(abs $ x-dx/2-x1) - dx/2, (abs $ y-dy/2-y1) - dy/2]
+         else rmaximum r [(abs $ x-dx/2-x1) - dx/2, (abs $ y-dy/2-y1) - dy/2]
+getImplicit2 (Circle r) =
+    \(x,y) -> (sqrt $ x * x + y * y) - r
 getImplicit2 (PolygonR _ points) =
     \p -> let
-        pair :: Int -> (ℝ2,ℝ2)
-        pair n = (points !! n, points !! (mod (n + 1) (length points) ) )
-        pairs =  [ pair n | n <- [0 .. (length points) - 1] ]
+        pair :: ℕ -> (ℝ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 =  map (\(a,b) -> (a ^-^ p, b ^-^ p) ) pairs
         crossing_points =
             [x2 ^-^ y2*(x2-x1)/(y2-y1) | ((x1,y1), (x2,y2)) <-relativePairs,
                ( (y2 <= 0) && (y1 >= 0) ) || ( (y2 >= 0) && (y1 <= 0) ) ]
-        seemsInRight = odd $ length $ filter (>0) $ nub crossing_points
-        seemsInLeft = odd $ length $ filter (<0) $ nub crossing_points
+        -- FIXME: use partition instead?
+        seemsInRight = odd . length . filter (>0) $ nub crossing_points
+        seemsInLeft = odd . length . filter (<0) $ nub crossing_points
         isIn = seemsInRight && seemsInLeft
-        dists = map (distFromLineSeg p) pairs :: [ℝ]
+        dists :: [ℝ]
+        dists = map (distFromLineSeg p) pairs
     in
         minimum dists * if isIn then -1 else 1
 -- (Rounded) CSG
 getImplicit2 (Complement2 symbObj) =
-    let
+    \p -> let
         obj = getImplicit2 symbObj
     in
-        \p -> - obj p
+        - obj p
 getImplicit2 (UnionR2 r symbObjs) =
-    let
+    \p -> let
         objs = map getImplicit2 symbObjs
     in
         if r == 0
-        then \p -> minimum $ map ($p) objs
-        else \p -> rminimum r $ map ($p) objs
+        then minimum $ map ($p) objs
+        else rminimum r $ map ($p) objs
 getImplicit2 (DifferenceR2 r symbObjs) =
     let
         objs = map getImplicit2 symbObjs
         obj = head objs
         complement :: forall a t. Num a => (t -> a) -> t -> a
-        complement obj' = \p -> - obj' p
+        complement obj' p = - obj' p
     in
         if r == 0
-        then \p -> maximum $ map ($p) $ obj:(map complement $ tail objs)
-        else \p -> rmaximum r $ map ($p) $ obj:(map complement $ tail objs)
+        then \p -> maximum . map ($p) $ obj:map complement (tail objs)
+        else \p -> rmaximum r . map ($p) $ obj:map complement (tail objs)
 getImplicit2 (IntersectR2 r symbObjs) =
-    let
+    \p -> let
         objs = map getImplicit2 symbObjs
     in
         if r == 0
-        then \p -> maximum $ map ($p) objs
-        else \p -> rmaximum r $ map ($p) objs
+        then maximum $ map ($p) objs
+        else rmaximum r $ map ($p) objs
 -- Simple transforms
 getImplicit2 (Translate2 v symbObj) =
-    let
+    \p -> let
         obj = getImplicit2 symbObj
     in
-        \p -> obj (p ^-^ v)
+        obj (p ^-^ v)
 getImplicit2 (Scale2 s@(sx,sy) symbObj) =
-    let
+    \p -> let
         obj = getImplicit2 symbObj
-        k = abs(max sx sy)
+        k = abs $ max sx sy
     in
-        \p -> k * obj (p ⋯/ s)
+        k * obj (p ⋯/ s)
 getImplicit2 (Rotate2 θ symbObj) =
-    let
+    \(x,y) -> let
         obj = getImplicit2 symbObj
     in
-        \(x,y) -> obj ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x)
+        obj ( x*(cos θ) + y*(sin θ), y*(cos θ) - x*(sin θ))
 -- Boundary mods
 getImplicit2 (Shell2 w symbObj) =
-    let
+    \p -> let
         obj = getImplicit2 symbObj
     in
-        \p -> abs (obj p) - w/2
+        (abs $ obj p) - w/2
 getImplicit2 (Outset2 d symbObj) =
-    let
+    \p -> let
         obj = getImplicit2 symbObj
     in
-        \p -> obj p - d
+        obj p - d
 -- Misc
 getImplicit2 (EmbedBoxedObj2 (obj,_)) = obj
 

Graphics/Implicit/ObjectUtil/GetImplicit3.hs

@@ -8,32 +8,41 @@
 
 module Graphics.Implicit.ObjectUtil.GetImplicit3 (getImplicit3) where
 
-import Prelude (Either(Left, Right), Int, abs, (-), (/), (*), sqrt, (+), atan2, max, cos, map, (==), minimum, ($), maximum, (**), sin, const, pi, (.), Bool(True, False), ceiling, floor, fromIntegral, return, error, head, tail, Num)
+import Prelude (Either(Left, Right), abs, (-), (/), (*), sqrt, (+), atan2, max, cos, map, (==), minimum, ($), maximum, (**), sin, const, pi, (.), Bool(True, False), ceiling, floor, return, error, head, tail, Num)
 
-import Graphics.Implicit.Definitions (ℝ, ℝ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ℝ)
+
 import Graphics.Implicit.MathUtil (rmaximum, rminimum, rmax)
-import qualified Data.Maybe as Maybe
-import qualified Data.Either as Either
+
+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)
 
+-- 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) -> rmaximum r
-    [abs (x-dx/2-x1) - dx/2, abs (y-dy/2-y1) - dy/2, abs (z-dz/2-z1) - dz/2]
-        where (dx, dy, dz) = (x2-x1, y2-y1, z2-z1)
+getImplicit3 (Rect3R r (x1,y1,z1) (x2,y2,z2)) =
+    \(x,y,z) -> let (dx, dy, dz) = (x2-x1, y2-y1, z2-z1)
+                in
+                  rmaximum r [(abs $ x-dx/2-x1) - dx/2, (abs $ y-dy/2-y1) - dy/2, (abs $ z-dz/2-z1) - dz/2]
 getImplicit3 (Sphere r ) =
-    \(x,y,z) -> sqrt (x*x + y*y + z*z) - r
+    \(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
@@ -59,11 +68,11 @@ getImplicit3 (DifferenceR3 r symbObjs) =
         objs = map getImplicit3 symbObjs
         obj = head objs
         complement :: forall a t. Num a => (t -> a) -> t -> a
-        complement obj' = \p -> - obj' p
+        complement obj' p = - obj' p
     in
         if r == 0
-        then \p -> maximum $ map ($p) $ obj:(map complement $ tail objs)
-        else \p -> rmaximum r $ map ($p) $ obj:(map complement $ tail objs)
+        then \p -> maximum $ map ($p) $ obj:map complement (tail objs)
+        else \p -> rmaximum r $ map ($p) $ obj:map complement (tail objs)
 -- Simple transforms
 getImplicit3 (Translate3 v symbObj) =
     let
@@ -73,40 +82,35 @@ getImplicit3 (Translate3 v symbObj) =
 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) =
     let
         obj = getImplicit3 symbObj
         rotateYZ :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)
-        rotateYZ θ obj' = \(x,y,z) -> obj' ( x, cos(θ)*y + sin(θ)*z, cos(θ)*z - sin(θ)*y)
+        rotateYZ θ obj' (x,y,z) = obj' ( x, y*(cos θ) + z*(sin θ), z*(cos θ) - y*(sin θ))
         rotateZX :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)
-        rotateZX θ obj' = \(x,y,z) -> obj' ( cos(θ)*x - sin(θ)*z, y, cos(θ)*z + sin(θ)*x)
+        rotateZX θ obj' (x,y,z) = obj' ( x*(cos θ) - z*(sin θ), y, z*(cos θ) + x*(sin θ))
         rotateXY :: ℝ -> (ℝ3 -> ℝ) -> (ℝ3 -> ℝ)
-        rotateXY θ obj' = \(x,y,z) -> obj' ( cos(θ)*x + sin(θ)*y, cos(θ)*y - sin(θ)*x, z)
+        rotateXY θ obj' (x,y,z) = obj' ( x*(cos θ) + y*(sin θ), y*(cos θ) - x*(sin θ), z)
     in
-        rotateYZ yz $ rotateZX zx $ rotateXY xy $ obj
+        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(θ)))))
+            v ^* (cos θ)
+            ^-^ (axis' `cross3` v) ^* (sin θ)
+            ^+^ (axis' ^* (axis' <.> (v ^* (1 - (cos θ)))))
 -- Boundary mods
 getImplicit3 (Shell3 w symbObj) =
     let
         obj = getImplicit3 symbObj
     in
-        \p -> abs (obj p) - w/2
+        \p -> (abs $ obj p) - w/2
 getImplicit3 (Outset3 d symbObj) =
     let
         obj = getImplicit3 symbObj
@@ -119,26 +123,27 @@ getImplicit3 (ExtrudeR r symbObj h) =
     let
         obj = getImplicit2 symbObj
     in
-        \(x,y,z) -> rmax r (obj (x,y)) (abs (z - h/2) - h/2)
+        \(x,y,z) -> rmax r (obj (x,y)) ((abs $ z - h/2) - h/2)
 getImplicit3 (ExtrudeRM r twist scale translate symbObj height) =
     let
         obj = getImplicit2 symbObj
-        twist' = Maybe.fromMaybe (const 0) twist
-        scale' = Maybe.fromMaybe (const 1) scale
-        translate' = Maybe.fromMaybe (const (0,0)) translate
+        twist' = fromMaybe (const 0) twist
+        scale' = fromMaybe (const 1) scale
+        translate' = 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)
+        scaleVec  s (x,y) = (x/s, y/s)
         rotateVec :: ℝ -> ℝ2 -> ℝ2
-        rotateVec θ (x,y) = (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ))
-        k = (pi :: ℝ)/(180:: ℝ)
+        rotateVec θ (x,y) = (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))
-                (abs (z - h/2) - h/2)
+                ((abs $ z - h/2) - h/2)
 getImplicit3 (ExtrudeOnEdgeOf symbObj1 symbObj2) =
     let
         obj1 = getImplicit2 symbObj1
@@ -153,16 +158,16 @@ getImplicit3 (RotateExtrude totalRotation round translate rotate symbObj) =
         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'))
+                (\(a,b) θ -> (a*θ/totalRotation', b*θ/totalRotation'))
                 (. (/k))
                 translate
         rotate' :: ℝ -> ℝ
         rotate' = Either.either
-                (\t -> \θ -> t*θ/totalRotation' )
+                (\t θ -> t*θ/totalRotation' )
                 (. (/k))
                 rotate
         twists = case rotate of
@@ -170,25 +175,25 @@ getImplicit3 (RotateExtrude totalRotation round translate rotate symbObj) =
                    _       -> False
     in
         \(x,y,z) -> minimum $ do
-            
+
             let
-                r = sqrt (x*x + y*y)
+                r = sqrt $ x*x + y*y
                 θ = atan2 y x
-                ns :: [Int]
+                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]
+                        [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')
@@ -196,9 +201,9 @@ getImplicit3 (RotateExtrude totalRotation round translate rotate symbObj) =
             return $
                 if capped
                 then rmax round'
-                    (abs (θvirt - (totalRotation' / 2)) - (totalRotation' / 2))
+                    ((abs $ θvirt - (totalRotation' / 2)) - (totalRotation' / 2))
                     (obj rz_pos)
                 else obj rz_pos
 -- FIXME: implement this, or implement a fallthrough function.
 --getImplicit3 (ExtrudeRotateR) =
-getImplicit3 (ExtrudeRotateR _ _ _ _) = error "ExtrudeRotateR unimplimented!"
+getImplicit3 ExtrudeRotateR{} = error "ExtrudeRotateR unimplimented!"

Graphics/Implicit/Primitives.hs

@@ -138,12 +138,12 @@ polygonR = PolygonR
 -- $ 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 +161,7 @@ class Object obj vec | obj -> vec where
         ℝ        -- ^ 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,7 +200,7 @@ class Object obj vec | obj -> vec where
         (vec -> ℝ)     -- ^ Implicit function
         -> (vec, vec)  -- ^ Bounding box
         -> obj         -- ^ Resulting object
-    
+
 
 instance Object SymbolicObj2 ℝ2 where
     translate   = Translate2
@@ -265,7 +265,7 @@ rotateExtrude = RotateExtrude
 extrudeOnEdgeOf :: SymbolicObj2 -> SymbolicObj2 -> SymbolicObj3
 extrudeOnEdgeOf = ExtrudeOnEdgeOf
 
-rotate3 :: (ℝ, ℝ, ℝ) -> SymbolicObj3 -> SymbolicObj3
+rotate3 :: ℝ3 -> SymbolicObj3 -> SymbolicObj3
 rotate3 = Rotate3
 
 rotate3V :: ℝ -> ℝ3 -> SymbolicObj3 -> SymbolicObj3
@@ -275,7 +275,7 @@ rotate3V = Rotate3V
 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

Makefile

@@ -1,65 +1,137 @@
-.PHONY: build install clean docs dist test examples tests
+# ImplicitCAD Makefile. Build and test Implicitcad.
 
-RTSOPTS=+RTS -N
-
-RESOPTS=-r 10
-
-#uncomment for profiling support.
-#PROFILING= --enable-library-profiling --enable-executable-profiling
-
-# stl2ps, from stltools, available from https://github.com/rsmith-nl/stltools/tree/develop
+## Locations of binaries used when running tests, or generating the images to go along with our README.md.
+# The location of stl2ps, from stltools, available from https://github.com/rsmith-nl/stltools/tree/develop
 stl2ps=/disk4/faikvm.com/stltools/stltools/stl2ps.py
-
-# convert, from imagemagick
+# The location of convert, from imagemagick
 convert=convert
-
+# The location of GHC, used to compile .hs examples.
+GHC=ghc
+# The location of the created extopenscad binary, for running shell based test cases.
 EXTOPENSCAD=dist/build/extopenscad/extopenscad
+# The location of the implicitsnap binary, which listens for requests via http. The backend of the website.
+IMPLICITSNAP=dist/build/implicitsnap/implicitsnap
+# The location of the benchmark binary, for benchmarking some implicitcad internals.
+BENCHMARK=dist/build/Benchmark/Benchmark
+# The location of the parser benchmark binary, specifically for benchmarking implicitcad's parser.
+PARSERBENCH=dist/build/parser-bench/parser-bench
+# The location of the created test binary, for running haskell test cases.
+TESTSUITE=dist/build/test-implicit/test-implicit
+# The location of it's source.
+TESTFILES=$(shell find tests/ParserSpec -name '*.hs')
+# The location of the documentation generator. for documenting (some of) the extopenscad language.
+DOCGEN=dist/build/docgen/docgen
 
-# FIXME: this used to be ./Setup install. what's going on?
-install: $(EXTOPENSCAD)
+## Options used when calling ImplicitCAD. for testing, and for image generation.
+# Enable multiple CPU usage.
+# Use the parallel garbage collector.
+# spit out some performance statistics.
+RTSOPTS=+RTS -N -qg -t
+# The resolution to generate objects at. FIXME: what does this mean in human terms? 
+RESOPTS=-r 50
+
+# Uncomment for profiling support. Note that you will need to recompile all of the libraries, as well.
+#PROFILING= --enable-profiling
+
+## FIXME: escape this right
+# Uncomment for valgrind on the examples.
+#VALGRIND=valgrind --tool=cachegrind --cachegrind-out-file=$$each.cachegrind.`date +%s`
+
+LIBFILES=$(shell find Graphics -name '*.hs')
+LIBTARGET=dist/build/Graphics/Implicit.o
+
+EXECTARGETS=$(EXTOPENSCAD) $(IMPLICITSNAP) $(BENCHMARK) $(TESTSUITE) $(PARSERBENCH) $(DOCGEN)
+TARGETS=$(EXECTARGETS) $(LIBTARGET)
+
+# Mark the below fake targets as unreal, so make will not get choked up if a file with one of these names is created.
+.PHONY: build install clean distclean nukeclean docs dist examples tests
+
+# Empty out the default suffix list, to make debugging output cleaner.
+.SUFFIXES:
+
+# Allow for us to (ab)use $$* in dependencies of rules.
+.SECONDEXPANSION:
+
+# Disable make's default builtin rules, to make debugging output cleaner.
+MAKEFLAGS += --no-builtin-rules
+
+# Build implicitcad binaries.
+build: $(TARGETS)
+
+# Install implicitcad.
+install: build
 	cabal install
 
+# Cleanup from using the rules in this file.
 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 docs/parser.md
+	rm -f $(TARGETS)
+	rm -rf dist/build/Graphics
+	rm -f dist/build/libHS*
+	rm -f Examples/example*.cachegrind.*
 
-distclean: clean
+# Clean up before making a release.
+distclean: clean Setup
+	./Setup clean
+	rm -f Setup Setup.hi Setup.o
+	rm -rf dist/
 	rm -f `find ./ -name *~`
 	rm -f `find ./ -name \#*\#`
 
+# Destroy the current user's cabal/ghc environment.
+nukeclean: distclean
+	rm -rf ~/.cabal/ ~/.ghc/
 
-docs: $(EXTOPENSCAD)
+# Generate documentation.
+docs: $(DOCGEN)
 	./Setup haddock
+	$(DOCGEN) > docs/escad.md
 
-dist: $(EXTOPENSCAD)
+# Upload to hackage?
+dist: $(TARGETS)
 	./Setup sdist
 
-test: $(EXTOPENSCAD)
-	./Setup test
-
+# Generate examples.
 examples: $(EXTOPENSCAD)
-	cd Examples && for each in `find ./ -name '*scad' -type f | sort`; do { time ../$(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
+	cd Examples && for each in `find ./ -name '*scad' -type f | sort`; do { ../$(EXTOPENSCAD) $$each $(RTSOPTS); } done
+	cd Examples && for each in `find ./ -name '*.hs' -type f | sort`; do { filename=$(basename "$$each"); filename="$${filename%.*}"; cd ..; $(GHC) Examples/$$filename.hs -o Examples/$$filename; cd Examples; echo $$filename; $$filename +RTS -t ; } done
 
-images:
+# Generate images from the examples, so we can upload the images to our website.
+images: examples
 	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: $(EXTOPENSCAD)
-	cd tests && for each in `find ./ -name '*scad' -type f | sort`; do { time ../$(EXTOPENSCAD) $$each ${RESOPTS} ${RTSOPTS}; } done
+# Hspec parser tests.
+tests: $(TESTSUITE) $(TESTFILES)
+#	cd tests && for each in `find ./ -name '*scad' -type f | sort`; do { ../$(EXTOPENSCAD) $$each ${RESOPTS} ${RTSOPTS}; } done
+	$(TESTSUITE)
 
-dist/build/extopenscad/extopenscad: Setup dist/setup-config
-	cabal build
+# The ImplicitCAD library.
+$(LIBTARGET): $(LIBFILES)
+	cabal build implicit
 
+# The parser test suite, since it's source is stored in a different location than the other binaries we build:
+dist/build/test-implicit/test-implicit: $(TESTFILES) Setup dist/setup-config $(LIBTARGET) $(LIBFILES)
+	cabal build test-implicit
+
+# Build a binary target with cabal.
+dist/build/%: programs/$$(word 2,$$(subst /, ,%)).hs Setup dist/setup-config $(LIBTARGET) $(LIBFILES)
+	cabal build $(word 2,$(subst /, ,$*))
+
+# Prepare to build.
 dist/setup-config: Setup implicit.cabal
-	cabal install --only-dependencies
-	cabal configure $(PROFILING)
+	cabal update
+	cabal install --only-dependencies --upgrade-dependencies $(PROFILING)
+	cabal configure --enable-tests --enable-benchmarks $(PROFILING)
 
+# The setup command, used to perform administrative tasks (haddock, upload to hackage, clean, etc...).
 Setup: Setup.*hs
-	ghc -O2 -Wall --make Setup
+	$(GHC) -O2 -Wall --make Setup
 

README.md

@@ -146,7 +146,7 @@ linear_extrude (height = 40, center=true, twist=90, r=5){
 ![A rounded twisted extrusion](http://faikvm.com/ImplicitCAD/example7.png)
 
 
-ImplicitCAD also provides full programmatic functionality, like variable assignment in loops, which are sadly absent in OpenSCAD. For example, the trivial program:
+ImplicitCAD also provides full programmatic functionality, like variable assignment in loops. For example, the trivial program:
 
 ```c
 // Example8.escad -- variable assignment in loops.

Release.md

@@ -0,0 +1,34 @@
+# Release Processes:
+
+Purpose of this document: to make sure i follow a consistent patern, when making changes to ImplicitCAD.
+
+## "no point" releases:
+
+### Comment / Format / Messages
+
+These changes don't improve anything but the code quality, messages output, or build system. they can add features to the parser, but cannot remove them. they may not change the md5 of the generated STL files.
+
+1. make sure test-implicit is all green.
+2. make sure parser-bench hasn't gone all out of control.
+3. make sure docgen hasn't changed it's output too much.
+
+push to master.
+
+### Math / Types
+These releases change the math engine, but only in a direction that is provably better, and shows in our examples.
+
+1. do all of the above.
+2. check 'make examples' output. look at the times that valgrind measures.
+3. check the md5sum of the .stl files output.
+
+If the md5sums of the last release and this one differ, run admesh on both, and examine the output. if the output is conclusively better for all changed examples, then proceed to push.
+
+push to master.
+
+## point releases:
+
+These releases change the quality of the output significantly enough that poking it with admesh is indeterminate, or they include changes to the parser such that old code would not work.
+
+
+
+## major releases:

Setup.hs

@@ -1,2 +1,3 @@
 import Distribution.Simple
+main :: IO ()
 main = defaultMain

Tools.md

@@ -0,0 +1,16 @@
+# Purpose of this document:
+
+List the external tools i've found useful with this codebase.
+
+# Tools:
+
+## Workflow:
+
+My workflow consists of:
+
+### admesh
+
+### meshlab
+
+## Code Checking
+'weeder' is useful.

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 []
-

implicit.cabal

@@ -1,117 +1,113 @@
-name:                implicit
-version:             0.1.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.
+Name:                implicit
+Version:             0.2.1
+Cabal-version:       >= 1.8
+Tested-with:         GHC >= 8.2
+Build-type:          Simple
+Synopsis:            A Math-inspired programmatic 2&3D CAD system: 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
+License:             AGPL-3
+License-file:        LICENSE
+Author:              Julia Longtin <julial@turinglace.com>
+Maintainer:          Julia Longtin <julial@turinglace.com>
+Homepage:            http://implicitcad.org/
+Category:            Graphics
 
-library
+Library
 
-    build-depends:
-        base >= 3 && < 5,
-        filepath,
-        directory,
-        download,
-        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
+    Build-depends:
+                  base >= 3 && < 5,
+                  filepath,
+                  directory,
+                  parsec,
+                  parallel,
+                  containers,
+                  deepseq,
+                  hspec,
+                  vector-space,
+                  text,
+                  monads-tf,
+                  bytestring,
+                  blaze-builder,
+                  blaze-markup,
+                  blaze-svg,
+                  storable-endian,
+                  JuicyPixels,
+                  transformers
 
-    ghc-options:
-        -Wall
--- for debugging only.
---        -Weverything
-        -O2
-        -optc-O3
--- cannot use, we use infinity in some calculations.
---        -optc-ffast-math
+    Ghc-options:
+                -O2
+                -optc-O3
+--                -dynamic
+                -- see GHC manual 8.2.1 section 6.5.1.
+                -feager-blackholing
+                -- for debugging.
+                -Wall
+                -Wextra
+                -Weverything
 
-    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
+    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.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.PolylineFormats
+                    Graphics.Implicit.Export.DiscreteAproxable
+                    -- These are exposed for docgen.
+                    Graphics.Implicit.ExtOpenScad.Primitives            
 
-    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
+    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.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
+                  -- Historic, but functional. Should be merged into MarchingSquaresFill.
+                  -- 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
 
-executable extopenscad
-
-   main-is: extopenscad.hs
-   hs-source-dirs: programs
-   build-depends:
+Executable extopenscad
+   Main-is: extopenscad.hs
+   Hs-source-dirs: programs
+   Build-depends:
                  base,
                  containers,
                  vector-space,
@@ -119,129 +115,114 @@ executable extopenscad
                  parallel,
                  optparse-applicative >= 0.10.0,
                  implicit
-   ghc-options:
-        -threaded
-        -rtsopts
-        -Wall
-        -O2
-        -optc-O3
-        -optc-ffast-math
+   Ghc-options:
+               -O2
+               -optc-O3
+               -threaded
+               -rtsopts
+--               -dynamic
+               -- see GHC manual 8.2.1 section 6.5.1.
+               -feager-blackholing
+               -- for debugging.
+               -Wall
+               -Wextra
+               -Weverything
 
--- FIXME: does not compile.
---Executable docgen
-
---   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
+   Hs-source-dirs: programs
    build-depends:
                  base,
-                 vector-space,
-                 text,
-                 JuicyPixels,
-                 blaze-builder,
-                 blaze-svg,
-                 blaze-markup,
-                 parallel,
-                 deepseq,
-                 vector-space,
-                 monads-tf,
+                 implicit
+   ghc-options:
+--               -dynamic
+               -- for debugging.
+               -Wall
+               -Wextra
+               -Weverything
+
+Executable implicitsnap
+   Main-is: implicitsnap.hs
+   Hs-source-dirs: programs
+   Build-depends:
+                 base,
                  bytestring,
-                 storable-endian,
-                 parsec,
-                 directory,
                  containers,
-                 filepath,
+                 implicit,
+                 parallel,
+                 parsec,
+                 silently,
                  snap-core,
                  snap-server,
-                 silently,
-                 transformers,
-                 implicit
-   ghc-options:
-        -threaded
-        -rtsopts
-        -Wall
-        -O2
-        -optc-O3
-        -optc-ffast-math
-
-executable Benchmark
-
-   main-is: Benchmark.hs
-   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,
+                 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
+               -Wextra
+               -Weverything
+
+Executable Benchmark
+   Main-is: Benchmark.hs
+   Hs-source-dirs: programs
+   Build-depends:
+                 base,
                  criterion,
-                 transformers,
                  implicit
-   ghc-options:
-        -threaded
-        -rtsopts
-        -Wall
-        -O2
-        -optc-O3
-        -optc-ffast-math
+   Ghc-options:
+               -O2
+               -optc-O3
+--               -dynamic
+               -- for debugging.
+               -Wall
+               -Wextra
+               -Weverything
 
-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
+Test-suite test-implicit
+    Type: exitcode-stdio-1.0
+    Build-depends:
+                  base,
+                  containers,
+                  hspec,
+                  implicit,
+                  mtl,
+                  parsec
+    Main-is: Main.hs
+    Hs-source-dirs: tests
+    Ghc-options:
+                -O2
+                -optc-O3
+--                -dynamic
+                -- for debugging.
+                -Wall
+                -Wextra
+                -Weverything
+    Other-Modules:
+                  ParserSpec.Expr
+                  ParserSpec.Statement
+                  ParserSpec.Util
 
-benchmark parser-bench
-    type: exitcode-stdio-1.0
-    hs-source-dirs: bench
-    main-is: ParserBench.hs
-    build-depends: base, criterion, random, parsec, implicit
-    ghc-options:
-        -Wall
-        -O2 -optc-O3
+Benchmark parser-bench
+    Type: exitcode-stdio-1.0
+    Build-depends: base, criterion, random, parsec, implicit
+    Main-is: parser-bench.hs
+    Hs-source-dirs: programs
+    Ghc-options:
+                -O2
+                -optc-O3
+--                -dynamic
+                -- for debugging.
+                -Wall
+                -Wextra
+                -Weverything
 
-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

@@ -2,26 +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 :)
 
--- Use criterion for benchmarking. see <http://www.serpentine.com/criterion/>
-import Criterion.Main
+import Prelude (($), (*), (/), String, IO, cos, pi, map, zip3, Maybe(Just, Nothing), Either(Left), fromIntegral, (++))
 
--- The parts of ImplicitCAD we know how to benchmark (in theory).
-import Graphics.Implicit (union, circle, writeSVG, writePNG2, writePNG3, writeSTL, SymbolicObj2, SymbolicObj3)
+-- Use criterion for benchmarking. see <http://www.serpentine.com/criterion/>
+import Criterion.Main (Benchmark, bgroup, bench, nf, nfAppIO, defaultMain)
+
+-- 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 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.
+-- 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
@@ -29,21 +34,28 @@ obj2d_1 =
         , 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)
-    where twist h = 35*cos(h*2*pi/60)
+    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
                    $ 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 (map (\n->((fromIntegral n)/precision)*x) [0..100::Fastℕ])
+                   (map (\n->((fromIntegral n)/precision)*y) [0..100::Fastℕ])
+                   (map (\n->((fromIntegral n)/precision)*z) [0..100::Fastℕ])
 
+-- | A third 3d object to benchmark.
 object3 :: SymbolicObj3
 object3 =
     difference
@@ -51,31 +63,45 @@ object3 =
         , 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
+    [ 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/docgen.hs

@@ -0,0 +1,172 @@
+-- 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 MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+
+import Prelude(IO, Show, String, Int, Maybe(Just,Nothing), Eq, return, ($), show, fmap, (++), putStrLn, filter, zip, null, map, undefined, const, Bool(True,False), fst, snd, sequence, (.), concat, head, tail, sequence, length, (>), (/=), (+))
+import Graphics.Implicit.ExtOpenScad.Primitives (primitives)
+import Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP,APFailIf,APExample,APTest,APTerminator,APBranch))
+
+import qualified Control.Exception as Ex (catch, SomeException)
+import Control.Monad (forM_, mapM)
+
+-- | Return true if the argument is of type ExampleDoc.
+isExample (ExampleDoc _ ) = True
+isExample _ = False
+
+-- | Return true if the argument is of type ArgumentDoc.
+isArgument (ArgumentDoc _ _ _) = True
+isArgument _ = False
+
+-- | Return true if the argument is of type Branch.
+isBranch (Branch _) = True
+isBranch _ = False
+
+dumpPrimitive :: String -> [DocPart] -> Int -> IO ()
+dumpPrimitive moduleName moduleDocList level = do
+  let
+    examples = filter isExample moduleDocList
+    arguments = filter isArgument moduleDocList
+    syntaxes = filter isBranch moduleDocList
+    moduleLabel = moduleName
+
+  if level /= 0
+    then
+    do
+      putStrLn $ "#" ++ moduleLabel
+    else
+    do
+      putStrLn moduleLabel
+      putStrLn (map (const '-') moduleLabel)
+      putStrLn ""
+
+  if null examples
+    then
+    return ()
+    else
+    do
+      putStrLn "#Examples:\n"
+      forM_ examples $ \(ExampleDoc example) -> do
+        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 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 ""
+
+  if null syntaxes
+    then
+      return ()
+    else
+      forM_ syntaxes $ \(Branch syntax) -> do
+        dumpPrimitive ("Syntax " ++ (show $ level+1)) syntax (level+1)
+
+-- | Our entrypoint. Generate one document describing all of our primitives.
+main :: IO ()
+main = do
+        docs <- mapM (getArgParserDocs.($ []).snd) primitives
+        let
+            names = map fst primitives
+            docname = "ImplicitCAD Primitives"
+
+        putStrLn (map (const '=') docname)
+        putStrLn docname
+        putStrLn (map (const '=') docname)
+        putStrLn ""
+        putStrLn ""
+        forM_ (zip names docs) $ \(moduleName, moduleDocList) -> do
+          dumpPrimitive moduleName moduleDocList 0
+
+-- | the format we extract documentation into
+data Doc = Doc String [DocPart]
+             deriving (Show)
+
+data DocPart = ExampleDoc String
+             | ArgumentDoc String (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) (\(e :: Ex.SomeException) -> return [])
+  if (otherDocs /= [Empty])
+    then
+        do
+          return $ [(ArgumentDoc name (fmap show fallback) doc)] ++ (otherDocs)
+    else
+        do
+          return $ [(ArgumentDoc name (fmap show fallback) doc)]
+
+getArgParserDocs (APFailIf _ _ child) = do
+  childResults <- getArgParserDocs child
+  return $ childResults
+
+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) = do
+  childResults <- getArgParserDocs child
+  return $ childResults
+
+-- 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)) (\(e :: Ex.SomeException) -> return [])
+  aResults <- getArgParserDocs $ head children
+  if (otherDocs /= [(Empty)])
+    then
+        do
+          return $ [Branch ((aResults)++(otherDocs))]
+    else
+        do
+          return aResults

programs/extopenscad.hs

@@ -3,16 +3,18 @@
 -- 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 #-}
+{-# LANGUAGE PatternGuards #-}
 
 -- 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, String, (++), ($), (*), (/), (==), (>), (**), (-), readFile, minimum, drop, error, map, fst, min, sqrt, tail, take, length, putStrLn, show, print, (>>=), lookup)
+
 -- Our Extended OpenScad interpreter, and functions to write out files in designated formats.
-import Graphics.Implicit (runOpenscad, writeSVG, writeBinSTL, writeOBJ, writeSCAD2, writeSCAD3, writeGCodeHacklabLaser, writePNG2, writePNG3)
+import Graphics.Implicit (runOpenscad, writeSVG, writeDXF2, writeBinSTL, 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)
@@ -37,7 +39,7 @@ import Graphics.Implicit.ExtOpenScad.Definitions (OVal (ONum))
 -- Operator to subtract two points. Used when defining the resolution of a 2d object.
 import Data.AffineSpace ((.-.))
 
-import Data.Monoid (Monoid, mappend, mconcat)
+import Data.Monoid (Monoid, mappend)
 
 import Control.Applicative ((<$>), (<*>))
 
@@ -47,13 +49,13 @@ import Options.Applicative (fullDesc, progDesc, header, auto, info, helper, help
 -- 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:
+-- | The following is needed to ensure backwards/forwards compatibility
+-- | with old versions of Data.Monoid:
 infixr 6 <>
 (<>) :: Monoid a => a -> a -> a
 (<>) = mappend
 
--- A datatype for containing our command line options.
+-- | Our command line options.
 data ExtOpenScadOpts = ExtOpenScadOpts
     { outputFile :: Maybe FilePath
     , outputFormat :: Maybe OutputFormat
@@ -61,7 +63,7 @@ data ExtOpenScadOpts = ExtOpenScadOpts
     , inputFile :: FilePath
     }
 
--- A datatype enumerating our output file formats types.
+-- | A type serving to enumerate our output formats.
 data OutputFormat
     = SVG
     | SCAD
@@ -69,10 +71,11 @@ data OutputFormat
     | GCode
     | 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)
@@ -82,18 +85,19 @@ formatExtensions =
     , ("gcode", GCode)
     , ("stl", STL)
     , ("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 =
-    maybe (error $ "Unrecognized output format: "<>ext) id
+    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 (
@@ -125,26 +129,28 @@ extOpenScadOpts = ExtOpenScadOpts
         <> 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
 
--- 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
-        where tryParse [] = []    -- If there is nothing left to try, fail
-              tryParse ((attempt, result):xs) =
-                  if (take (length attempt) myvalue) == attempt
-                  then [(result, drop (length attempt) myvalue)]
-                  else tryParse xs
+        where
+          tryParse :: [(String, OutputFormat)] -> [(OutputFormat, String)]
+          tryParse [] = []    -- If there is nothing left to try, fail
+          tryParse ((attempt, result):xs) =
+              if take (length attempt) myvalue == attempt
+              then [(result, drop (length attempt) myvalue)]
+              else tryParse xs
 
--- Find the resolution to raytrace at.
-getRes :: (Map.Map [Char] OVal, [SymbolicObj2], [SymbolicObj3]) -> ℝ
--- First, use a resolution specified by a variable in the input file.
+-- | 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.
+-- | Use a resolution chosen for 3D objects.
 -- FIXME: magic numbers.
 getRes (varlookup, _, obj:_) =
     let
@@ -153,19 +159,19 @@ getRes (varlookup, _, obj:_) =
     in case fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of
         ONum qual | qual > 0  -> min (minimum [x,y,z]/2) ((x*y*z/qual)**(1/3) / 22)
         _                     -> min (minimum [x,y,z]/2) ((x*y*z)**(1/3) / 22)
--- Use a resolution chosen for 2D objects.
+-- | Use a resolution chosen for 2D objects.
 -- FIXME: magic numbers.
 getRes (varlookup, obj:_, _) =
     let
         (p1,p2) = getBox2 obj
         (x,y) = p2 .-. p1
     in case fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of
-        ONum qual | qual > 0 -> min (min x y/2) ((x*y/qual)**0.5 / 30)
-        _                    -> min (min x y/2) ((x*y)**0.5 / 30)
--- fallthrough value.
+        ONum qual | qual > 0 -> min (min x y/2) (sqrt(x*y/qual) / 30)
+        _                    -> min (min x y/2) (sqrt(x*y) / 30)
+-- | fallthrough value.
 getRes _ = 1
 
--- 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
@@ -176,36 +182,37 @@ export3 posFmt 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
 
--- Interpret arguments, and render the object defined in the supplied input file.
-run :: ExtOpenScadOpts -> IO()
+-- | Interpret arguments, and render the object defined in the supplied input file.
+run :: ExtOpenScadOpts -> IO ()
 run args = do
 
-    putStrLn $ "Loading File."
+    putStrLn "Loading File."
     content <- readFile (inputFile args)
 
     let format =
             case () of
-                _ | Just fmt <- outputFormat args -> Just $ fmt
+                _ | Just fmt <- outputFormat args -> Just fmt
                 _ | Just file <- outputFile args  -> Just $ guessOutputFormat file
                 _                                 -> Nothing
-    putStrLn $ "Processing File."
+    putStrLn "Processing File."
 
     case runOpenscad content of
-        Left err -> putStrLn $ show $ err
+        Left err -> print err
         Right openscadProgram -> do
             s@(_, obj2s, obj3s) <- openscadProgram
-            let res = maybe (getRes s) id (resolution args)
+            let res = fromMaybe (getRes s) (resolution args)
             let basename = fst (splitExtension $ inputFile args)
             let posDefExt = case format of
                                 Just f  -> Prelude.lookup f (map swap formatExtensions)
@@ -218,7 +225,7 @@ run args = do
                     putStrLn $ "Rendering 3D object to " ++ output
                     putStrLn $ "With resolution " ++ show res
                     putStrLn $ "In box " ++ show (getBox3 obj)
-                    putStrLn $ show obj
+                    print obj
                     export3 format res output obj
                 ([obj], []) -> do
                     let output = fromMaybe
@@ -227,17 +234,17 @@ run args = do
                     putStrLn $ "Rendering 2D object to " ++ output
                     putStrLn $ "With resolution " ++ show res
                     putStrLn $ "In box " ++ show (getBox2 obj)
-                    putStrLn $ show obj
+                    print obj
                     export2 format res output obj
                 ([], []) -> putStrLn "No objects to render."
-                _        -> putStrLn "Multiple/No objects, what do you want to render?"
+                _        -> putStrLn "A mixture of 2D and 3D objects, what do you want to render?"
 
--- The entry point. Use the option parser then run the extended OpenScad code.
-main :: IO()
+-- | 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." 
+              <> progDesc "ImplicitCAD: Extended OpenSCAD interpreter."
               <> header "extopenscad - Extended OpenSCAD"
               )

programs/implicitsnap.hs

@@ -5,31 +5,44 @@
 -- Allow us to use explicit foralls when writing function type declarations.
 {-# LANGUAGE ExplicitForAll #-}
 
-{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
+-- 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, ($), (++), (>), (.), (-), (/), (*), (**), sqrt, min, max, minimum, maximum, show, return)
+
 import Control.Applicative ((<|>))
 
-import Snap.Core (Snap, route, writeBS, method, Method(GET), modifyResponse, setContentType, getRequest, rqParam)
+import Snap.Core (Snap, route, writeBS, method, Method(GET), modifyResponse, setContentType, setTimeout, getRequest, rqParam)
 import Snap.Http.Server (quickHttpServe)
 import Snap.Util.GZip (withCompression)
 
 -- 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))
+import Graphics.Implicit.ExtOpenScad.Definitions (OVal (ONum), VarLookup)
 
 -- Functions for finding a box around an object, so we can define the area we need to raytrace inside of.
 import Graphics.Implicit.ObjectUtil (getBox2, getBox3)
 
+-- Definitions of the datatypes used for 2D objects, 3D objects, and for defining the resolution to raytrace at.
 import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3, ℝ)
 
+-- Use default values when a Maybe is Nothing.
+import Data.Maybe (fromMaybe)
+
 import Graphics.Implicit.Export.TriangleMeshFormats (jsTHREE, stl)
 import Graphics.Implicit.Export.PolylineFormats (svg, hacklabLaserGCode)
 
+-- Operator to subtract two points. Used when defining the resolution of a 2d object.
+import Data.AffineSpace ((.-.))
+
 -- class DiscreteApprox
 import Graphics.Implicit.Export.DiscreteAproxable (discreteAprox)
 
@@ -45,33 +58,62 @@ 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"
+    setTimeout 600
     request <- getRequest
     case (rqParam "source" request, rqParam "callback" request, rqParam "format" request)  of
-        (Just [source], Just [callback], Nothing) -> do
-            writeBS $ BS.Char.pack $ executeAndExport
+        (Just [source], Just [callback], Nothing) ->
+            writeBS . BS.Char.pack $ executeAndExport
                 (BS.Char.unpack source)
                 (BS.Char.unpack callback)
                 Nothing
-        (Just [source], Just [callback], Just [format]) -> do
-            writeBS $ BS.Char.pack $ executeAndExport
+        (Just [source], Just [callback], Just [format]) ->
+            writeBS . BS.Char.pack $ executeAndExport
                 (BS.Char.unpack source)
                 (BS.Char.unpack callback)
                 (Just $ BS.Char.unpack format)
         (_, _, _)       -> writeBS "must provide source and callback as 1 GET variable each"
 
+-- | Find the resolution to raytrace at.
 getRes :: forall k. (Data.String.IsString k, Ord k) => (Map k OVal, [SymbolicObj2], [SymbolicObj3]) -> ℝ
+-- | If a resolution was specified in the input file, just use it.
+getRes (Map.lookup "$res" -> Just (ONum res), _, _) = res
+-- | If there was no resolution specified, use a resolution chosen for 3D objects.
+--   FIXME: magic numbers.
+getRes (varlookup, _, obj:_) =
+    let
+        ((x1,y1,z1),(x2,y2,z2)) = getBox3 obj
+        (x,y,z) = (x2-x1, y2-y1, z2-z1)
+    in case fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of
+        ONum qual | qual > 0  -> min (minimum [x,y,z]/2) ((x*y*z/qual)**(1/3) / 22)
+        _                     -> min (minimum [x,y,z]/2) ((x*y*z     )**(1/3) / 22)
+-- | ... Or use a resolution chosen for 2D objects.
+--   FIXME: magic numbers.
+getRes (varlookup, obj:_, _) =
+    let
+        (p1,p2) = getBox2 obj
+        (x,y) = p2 .-. p1
+    in case fromMaybe (ONum 1) $ Map.lookup "$quality" varlookup of
+        ONum qual | qual > 0 -> min ((min x y)/2) (sqrt(x*y/qual) / 30)
+        _                    -> min ((min x y)/2) (sqrt(x*y     ) / 30)
+-- | fallthrough value.
+getRes _ = 1
+
+{-
 getRes (varlookup, obj2s, obj3s) =
     let
         qual = case Map.lookup "$quality" varlookup of
@@ -83,8 +125,8 @@ getRes (varlookup, obj2s, obj3s) =
                 where
                     ((x1,y1,z1),(x2,y2,z2)) = getBox3 obj
                     (x,y,z) = (x2-x1, y2-y1, z2-z1)
-            (obj:_, _) -> ( min (min x y/2) ((x*y     )**0.5 / 30)
-                          , min (min x y/2) ((x*y/qual)**0.5 / 30) )
+            (obj:_, _) -> ( min (min x y/2) (sqrt(x*y     ) / 30)
+                          , min (min x y/2) (sqrt(x*y/qual) / 30) )
                 where
                     ((x1,y1),(x2,y2)) = getBox2 obj
                     (x,y) = (x2-x1, y2-y1)
@@ -98,20 +140,23 @@ getRes (varlookup, obj2s, obj3s) =
             if qual <= 30
             then qualRes
             else -1
+-}
 
-
-getWidth :: forall t. (t, [SymbolicObj2], [SymbolicObj3]) -> ℝ
+-- | get the maximum dimension of the object being rendered.
+--   FIXME: shouldn't this get the diagonal across the box?
+getWidth :: (VarLookup, [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
+getWidth (_,    [],    []) = 0
 
 -- | Give an openscad object to run and the basename of
 --   the target to write to... write an object!
 executeAndExport :: String -> String -> Maybe String -> String
 executeAndExport content callback maybeFormat =
     let
+        showB :: IsString t => Bool -> t
         showB True  = "true"
         showB False = "false"
         callbackF :: Bool -> Bool -> ℝ -> String -> String
@@ -119,6 +164,7 @@ executeAndExport content callback maybeFormat =
             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 -> String
         callbackS str   msg = callback ++ "([" ++ show str ++ "," ++ show msg ++ ",null,null]);"
     in case runOpenscad content of
         Left err ->
@@ -130,7 +176,7 @@ executeAndExport content callback maybeFormat =
                 msgs = showErrorMessages' $ errorMessages err
             in callbackF False False 1 $ (\s-> "error (" ++ show line ++ "):" ++ s) msgs
         Right openscadProgram -> unsafePerformIO $ do
-            (msgs,s) <- capture $ openscadProgram
+            (msgs,s) <- capture openscadProgram
             let
                 res = getRes   s
                 w   = getWidth s
@@ -162,6 +208,7 @@ executeAndExport content callback maybeFormat =
                     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"
 
 

programs/parser-bench.hs

@@ -1,9 +1,10 @@
-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
+import Prelude (IO, String, Int, Either(Left, Right), return, show, ($), otherwise, (==), (-), (++), 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"
@@ -24,7 +25,7 @@ assignments :: Int -> String
 assignments n = concat ["x = (foo + bar);\n" | _ <- [1..n]]
 
 intList :: Int -> String
-intList n = "[" ++ concat [(show i) ++ "," | i <- [1..n]] ++ "0]"
+intList n = "[" ++ concat [show i ++ "," | i <- [1..n]] ++ "0]"
 
 parseExpr :: String -> Expr
 parseExpr s = case parse expr0 "src" s of
@@ -32,7 +33,7 @@ parseExpr s = case parse expr0 "src" s of
                Right e -> e
 
 parseStatements :: String -> [StatementI]
-parseStatements s = case parseProgram "src" s of
+parseStatements s = case parseProgram s of
                      Left err -> error (show err)
                      Right e -> e
 
@@ -45,12 +46,12 @@ deepArithmetic n
 
 run :: String -> (String -> a) -> String -> Benchmark
 run name func input =
-  env (return $ input) $ \s ->
+  env (return input) $ \s ->
   bench name $ whnf func s
 
 main :: IO ()
 main =
-  defaultMain $
+  defaultMain
   [ bgroup "comments"
     [ run "line" parseStatements (lineComments 5000)
     , run "block" parseStatements (blockComments 10 500)

stack.yaml

@@ -1,14 +1,16 @@
 # 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-8.18
+
+resolver: lts-13.12
 
 # 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: []
+extra-deps:
+- storable-endian-0.2.6
 
 # Override default flag values for local packages and extra-deps
 flags: {}

tests/Main.hs

@@ -1,8 +1,22 @@
-import Test.Hspec
-import ParserSpec.Statement
-import ParserSpec.Expr
+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
+-- Copyright (C) 2018, Julia Longtin (julial@turinglace.com)
+-- Released under the GNU AGPLV3+, see LICENSE
+
+-- be explicit about what we import.
+import Prelude (($), IO)
+
+-- our testing engine.
+import Test.Hspec(hspec, describe)
+
+-- the test forstatements.
+import ParserSpec.Statement(statementSpec)
+
+-- the test for expressions.
+import ParserSpec.Expr(exprSpec)
 
 main :: IO ()
 main = hspec $ do
-  describe "expressions" $ exprSpec
-  describe "statements" $ statementSpec
+  -- run tests against the expression engine.
+  describe "expressions" exprSpec
+  -- and now, against the statement engine.
+  describe "statements" statementSpec

tests/ParserSpec/Expr.hs

@@ -1,103 +1,174 @@
+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
+-- Copyright (C) 2014-2017, Julia Longtin (julial@turinglace.com)
+-- Released under the GNU AGPLV3+, see LICENSE
+
 module ParserSpec.Expr (exprSpec) where
 
-import Test.Hspec
-import Graphics.Implicit.ExtOpenScad.Definitions
-import Graphics.Implicit.ExtOpenScad.Parser.Expr
-import Graphics.Implicit.ExtOpenScad.Parser.Statement
-import ParserSpec.Util
-import Text.ParserCombinators.Parsec hiding (State)
-import Data.Either
+-- Be explicit about what we import.
+import Prelude (Bool(True, False), ($))
 
-infixr 1 -->
-(-->) :: String -> Expr -> Expectation
-(-->) source expr =
-  (parseExpr source) `shouldBe` Right expr
+-- Hspec, for writing specs.
+import Test.Hspec (describe, Expectation, Spec, it, pendingWith, specify)
 
-infixr 1 -->+
-(-->+) :: String -> (Expr, String) -> Expectation
-(-->+) source (result, leftover) =
-  (parseWithLeftOver expr0 source) `shouldBe` (Right (result, leftover))
+-- Parsed expression components.
+import Graphics.Implicit.ExtOpenScad.Definitions (Expr(Var, ListE, (:$)), Pattern(Name))
+
+-- The type used for variables, in ImplicitCAD.
+import Graphics.Implicit.Definitions (ℝ)
+
+-- Our utility library, for making these tests easier to read.
+import ParserSpec.Util ((-->), fapp, num, bool, stringLiteral, plus, minus, mult, modulo, power, divide, negate, and, or, not, gt, lt, ternary, append, index, lambda, parseWithLeftOver)
+
+-- 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"
 
+negationIssue :: Expectation -> Expectation
+negationIssue _ = pendingWith "parser doesn't handle negation operator correctly"
+
 logicalSpec :: Spec
 logicalSpec = do
-  it "handles not" $ "!foo" --> (app' "!" [Var "foo"])
+  describe "not" $ do
+    specify "single" $ "!foo" --> not [Var "foo"]
+    specify "multiple" $
+      negationIssue $ "!!!foo" --> not [not [not [Var "foo"]]]
   it "handles and/or" $ do
-    "foo && bar" --> app' "&&" [Var "foo", Var "bar"]
-    "foo || bar" --> app' "||" [Var "foo", Var "bar"]
+    "foo && bar" --> and [Var "foo", Var "bar"]
+    "foo || bar" --> or [Var "foo", Var "bar"]
   describe "ternary operator" $ do
     specify "with primitive expressions" $
-      "x ? 2 : 3" --> app' "?" [Var "x", num 2, num 3]
+      "x ? 2 : 3" --> ternary [Var "x", num 2, num 3]
     specify "with parenthesized comparison" $
-      "(1 > 0) ? 5 : -5" --> app' "?" [app' ">" [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" $
-      ternaryIssue $ "1 > 0 ? 5 : -5" --> app' "?" [app' ">" [num 1, num 0], num 5, num (-5)]
+      ternaryIssue $ "1 > 0 ? 5 : -5" --> ternary [gt [num 1, num 0], num 5, num (-5)]
     specify "with comparison in head position, and addition in tail" $
       ternaryIssue $ "1 > 0 ? 5 : 1 + 2" -->
-      app' "?" [app' ">" [num 1, num 0], num 5, app "+" [num 1, num 2]]
+        ternary [gt [num 1, num 0], num 5, plus [num 1, num 2]]
 
 literalSpec :: Spec
 literalSpec = do
-  it "handles integers" $ do
+  it "handles integers" $
     "12356" -->  num 12356
-  it "handles floats" $ do
+  it "handles positive leading zero integers" $ do
+    "000012356" -->  num 12356
+  it "handles zero integer" $ do
+    "0" -->  num 0
+  it "handles leading zero integer" $ do
+    "0000" -->  num 0
+  it "handles floats" $
     "23.42" -->  num 23.42
   describe "booleans" $ do
     it "accepts true" $ "true" --> bool True
     it "accepts false" $ "false" --> bool False
 
+letBindingSpec :: Spec
+letBindingSpec = do
+  it "handles let with integer binding and spaces" $ do
+    "let ( a = 1 ) a" --> lambda [Name "a"] (Var "a") [num 1]
+  it "handles multiple variable let" $ do
+    "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" $ do
+    "let () a" --> (Var "a")
+  it "handles nested let" $ do
+    "let(a=x) let(b = y) a + b" --> lambda [Name "a"] ((lambda [Name "b"] (plus [Var "a", Var "b"])) [Var "y"]) [Var "x"]
+
 exprSpec :: Spec
 exprSpec = do
   describe "literals" literalSpec
-  describe "identifiers" $ do
+  describe "identifiers" $
     it "accepts valid variable names" $ do
       "foo" --> Var "foo"
       "foo_bar" --> Var "foo_bar"
-  describe "literals" $ literalSpec
   describe "grouping" $ do
-    it "allows parens" $ do
+    it "allows parens" $
       "( false )" -->  bool False
-    it "handles vectors" $ do
+    it "handles vectors" $
       "[ 1, 2, 3 ]" -->  ListE [num 1, num 2, num 3]
-    it "handles lists" $ do
+    it "handles empty vectors" $ do
+      "[]" -->  ListE []
+    it "handles single element vectors" $ do
+      "[a]" -->  ListE [Var "a"]
+    it "handles nested vectors" $ do
+      "[ 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]
     it "handles generators" $
-      "[ a : 1 : b + 10 ]" -->
-      (app "list_gen" [Var "a", num 1, app "+" [Var "b", num 10]])
+      "[ a : b ]" -->
+      fapp "list_gen" [Var "a", Var "b"]
+    it "handles generators with expression" $
+      "[ a : b + 10 ]" -->
+      fapp "list_gen" [Var "a", 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]" --> Var "index" :$ [Var "foo", num 23]
+      "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 call with single argument" $
+      "foo(1)" --> Var "foo" :$ [num 1]
+    it "handles single function call with multiple arguments" $
+      "foo(1, 2, 3)" --> Var "foo" :$ [num 1, num 2, num 3]
+    it "handles multiple function calls" $
+      "foo(1)(2)(3)" --> ((Var "foo" :$ [num 1]) :$ [num 2]) :$ [num 3]
 
   describe "arithmetic" $ do
     it "handles unary +/-" $ do
       "-42" --> num (-42)
       "+42" -->  num 42
+    it "handles unary - with extra spaces" $ do
+      "-  42" --> num (-42)
+    it "handles unary + with extra spaces" $ do
+      "+  42" -->  num 42
+    it "handles unary - with parentheses" $ do
+      "-(4 - 3)" -->  negate [ minus [num 4, num 3]]
+    it "handles unary + with parentheses" $ do
+      "+(4 - 1)" -->  minus [num 4, num 1]
+    it "handles unary - with identifier" $ do
+      "-foo" --> negate [Var "foo"]
+    it "handles unary + with identifier" $ do
+      "+foo" -->  Var "foo"
+    it "handles unary - with string literal" $ do
+      "-\"foo\"" --> negate [stringLiteral "foo"]
+    it "handles unary + with string literal" $ do
+      "+\"foo\"" -->  stringLiteral "foo"
     it "handles +" $ do
-      "1 + 2" --> app "+" [num 1, num 2]
-      "1 + 2 + 3" --> app "+" [num 1, num 2, num 3]
+      "1 + 2" --> plus [num 1, num 2]
+      "1 + 2 + 3" --> plus [num 1, num 2, num 3]
     it "handles -" $ do
-      "1 - 2" --> app' "-" [num 1, num 2]
-      "1 - 2 - 3" --> app' "-" [app' "-" [num 1, num 2], num 3]
+      "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" --> app "+" [num 1, app' "-" [num 2, num 3]]
-      "2 - 3 + 4" --> app "+" [app' "-" [num 2, num 3], num 4]
-      "1 + 2 - 3 + 4" --> app "+" [num 1, app' "-" [num 2, num 3], num 4]
-      "1 + 2 - 3 + 4 - 5 - 6" --> app "+" [num 1,
-                                           app' "-" [num 2, num 3],
-                                           app' "-" [app' "-" [num 4, num 5],
+      "1 + 2 - 3" --> plus [num 1, minus [num 2, num 3]]
+      "2 - 3 + 4" --> plus [minus [num 2, num 3], num 4]
+      "1 + 2 - 3 + 4" --> plus [num 1, minus [num 2, num 3], num 4]
+      "1 + 2 - 3 + 4 - 5 - 6" --> plus [num 1,
+                                           minus [num 2, num 3],
+                                           minus [minus [num 4, num 5],
                                                      num 6]]
     it "handles exponentiation" $
-      "x ^ y" -->  app' "^" [Var "x", Var "y"]
+      "x ^ y" -->  power [Var "x", Var "y"]
+    it "handles multiple exponentiations" $
+      "x ^ y ^ z" -->  power [Var "x", power [Var "y", Var "z"]]
     it "handles *" $ do
-      "3 * 4" -->  app "*" [num 3, num 4]
-      "3 * 4 * 5" -->  app "*" [num 3, num 4, num 5]
+      "3 * 4" -->  mult [num 3, num 4]
+      "3 * 4 * 5" -->  mult [num 3, num 4, num 5]
     it "handles /" $
-      "4.2 / 2.3" -->  app' "/" [num 4.2, num 2.3]
+      "4.2 / 2.3" -->  divide [num 4.2, num 2.3]
     it "handles precedence" $
-      parseExpr "1 + 2 / 3 * 5" `shouldBe`
-      (Right $ app "+" [num 1, app "*" [app' "/" [num 2, num 3], num 5]])
-  it "handles append" $
-    parseExpr "foo ++ bar ++ baz" `shouldBe`
-    (Right $ app "++" [Var "foo", Var "bar", Var "baz"])
+      "1 + 2 / 3 * 5" --> plus [num 1, mult [divide [num 2, num 3], num 5]]
+    it "handles append" $
+      "foo ++ bar ++ baz" --> append [Var "foo", Var "bar", Var "baz"]
   describe "logical operators" logicalSpec
+  describe "let expressions" letBindingSpec
+  describe "application" $ do
+    specify "base case" $ "foo(x)" --> Var "foo" :$ [Var "x"]
+    specify "multiple arguments" $
+      "foo(x, 1, 2)" --> Var "foo" :$ [Var "x", num 1, num 2]
+    specify "multiple" $
+      "foo(x, 1, 2)(5)(y)" --> ((Var "foo" :$ [Var "x", num 1, num 2]) :$ [num 5]) :$ [Var "y"]
+    specify "multiple, with indexing" $
+      "foo(x)[0](y)" --> (index [Var "foo" :$ [Var "x"], num 0] :$ [Var "y"])

tests/ParserSpec/Statement.hs

@@ -1,82 +1,97 @@
+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
+-- Copyright (C) 2014-2017, Julia Longtin (julial@turinglace.com)
+-- Released under the GNU AGPLV3+, see LICENSE
+
+-- | Statement related hspec tests.
 module ParserSpec.Statement (statementSpec) where
 
-import Test.Hspec
-import Text.ParserCombinators.Parsec hiding (State)
-import ParserSpec.Util
-import Graphics.Implicit.ExtOpenScad.Definitions
-import Graphics.Implicit.ExtOpenScad.Parser.Statement
-import Data.Either
+import Prelude (String, Maybe(Just), Bool(True), ($))
 
-parsesAs :: String -> [StatementI] -> Expectation
-parsesAs source stmts =
-  (parseProgram "src" source) `shouldBe` Right stmts
+import Test.Hspec (Spec, Expectation, shouldBe, shouldSatisfy, it, pendingWith, describe)
 
+import ParserSpec.Util (bool, num, minus, plus, mult, index)
+
+import Graphics.Implicit.ExtOpenScad.Definitions (StatementI(StatementI), Symbol, Expr(ListE, LamE, Var, (:$)), Statement(NewModule, ModuleCall, If, (:=)), Pattern(Name, ListP))
+
+-- Parse an ExtOpenScad program.
+import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram)
+
+import Data.Either (Either(Right), isLeft)
+
+import Text.ParserCombinators.Parsec (Line, Column)
+
+-- | an expectation that a string is equivalent to a statement.
+infixr 1 -->
+(-->) :: String -> [StatementI] -> Expectation
+(-->) source stmts =
+    parseProgram source `shouldBe` Right stmts
+
+-- | an expectation that a string generates an error.
 parsesAsError :: String -> Expectation
-parsesAsError source =
-  (parseProgram "src" source) `shouldSatisfy` isLeft
+parsesAsError source = parseProgram  source `shouldSatisfy` isLeft
 
+-- | A single statement.
 single :: Statement StatementI -> [StatementI]
-single st = [StatementI 1 st]
+single st = [StatementI 1 1 st]
 
-call :: Symbol -> [(Maybe Symbol, Expr)] -> [StatementI] -> StatementI
-call name args stmts = StatementI 1 (ModuleCall name args stmts)
+-- | A function call.
+call :: Symbol -> Column -> [(Maybe Symbol, Expr)] -> [StatementI] -> StatementI
+call name position args stmts = StatementI 1 position (ModuleCall name args stmts)
 
+-- | Test a simple if block.
 ifSpec :: Spec
-ifSpec = do
-  it "parses" $
-    "if (true) { a(); } else { b(); }" `parsesAs` (
-      single $ If (bool True) [call "a" [] []] [call "b" [] []])
+ifSpec = it "parses" $
+    "if (true) { a(); } else { b(); }" -->
+      single ( If (bool True) [call "a" 13 [] []] [call "b" 27 [] []])
 
+-- | Test assignments.
 assignmentSpec :: Spec
 assignmentSpec = do
   it "parses correctly" $
-    "y = -5;" `parsesAs` (single $ Name "y" := (num (-5)))
+    "y = -5;" --> single ( Name "y" := num (-5))
   it "handles pattern matching" $
-    "[x, y] = [1, 2];" `parsesAs`
-    (single $ ListP [Name "x", Name "y"] := (ListE [num 1, num 2]))
-  it "handles function definitions" $
-    "foo (x, y) = x * y;" `parsesAs` single fooFunction
-  it "handles the function keyword" $
-    "function foo(x, y) = x * y;" `parsesAs` single fooFunction
-  it "nested indexing" $
-    "x = [y[0] - z * 2];" `parsesAs`
-    (single $ Name "x" := ListE [app' "-" [app' "index" [Var "y", num 0],
-                                           app "*" [Var "z", num 2]]])
+    "[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 "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
-    fooFunction = Name "foo" := (LamE [Name "x", Name "y"]
-                                 (app "*" [Var "x", Var "y"]))
+    fooFunction :: Statement st
+    fooFunction = Name "foo" := LamE [Name "x", Name "y"]
+                                (mult [Var "x", Var "y"])
 
+-- | the parser fails on as empty file. This can't be right.
 emptyFileIssue :: Expectation -> Expectation
 emptyFileIssue _ = pendingWith "parser should probably allow empty files"
 
+-- | Our entry points. Test all of the statements.
 statementSpec :: Spec
 statementSpec = do
-  describe "empty file" $ do
+  describe "empty file" $
     it "returns an empty list" $
-      emptyFileIssue $ "" `parsesAs` []
-
-  describe "line comment" $ do
-    it "parses as empty" $ emptyFileIssue $ "// foish bar\n" `parsesAs` []
-
-  describe "module call" $ do
-    it "parses" $
-      "foo();" `parsesAs` (single $ ModuleCall "foo" [] [])
-  describe "difference of two cylinders" $ do
+      emptyFileIssue $ "" --> []
+  describe "assignment" assignmentSpec
+  describe "if" ifSpec
+  describe "line comment" $
+    it "parses as empty" $ emptyFileIssue $ "// foish bar\n" --> []
+  describe "module call" $
+    it "parses" $ "foo();" --> single (ModuleCall "foo" [] [])
+  describe "difference of two cylinders" $
     it "parses correctly" $
       "difference(){ cylinder(r=5,h=20); cylinder(r=2,h=20); }"
-      `parsesAs` single (
+      --> single (
         ModuleCall "difference" [] [
-           (call "cylinder" [(Just "r", num 5.0),
+           call "cylinder" 15 [(Just "r", num 5.0),
                              (Just "h", num 20.0)]
-            []),
-           (call "cylinder" [(Just "r", num 2.0),
+            [],
+           call "cylinder" 35 [(Just "r", num 2.0),
                              (Just "h", num 20.0)]
-            [])])
-
-  describe "empty module definition" $ do
+            []])
+  describe "empty module definition" $
     it "parses correctly" $
-      "module foo_bar() {}" `parsesAs` (single $ NewModule "foo_bar" [] [])
-
-  describe "assignment" assignmentSpec
-
-  describe "if" ifSpec
+      "module foo_bar() {}" --> single (NewModule "foo_bar" [] [])

tests/ParserSpec/Util.hs

@@ -1,45 +1,114 @@
+-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
+-- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)
+-- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com)
+-- Released under the GNU AGPLV3+, see LICENSE
+
+-- Allow us to use explicit foralls when writing function type declarations.
+{-# LANGUAGE ExplicitForAll #-}
+
+-- Utilities
 module ParserSpec.Util
-       ( num
+       ( (-->)
+       , (-->+)
+       , num
        , bool
-       , app
-       , app'
-       , parseWithEof
+       , stringLiteral
+       , fapp
+       , plus
+       , minus
+       , mult
+       , modulo
+       , power
+       , divide
+       , not
+       , and
+       , or
+       , gt
+       , lt
+       , negate
+       , ternary
+       , append
+       , index
+       , lambda
        , parseWithLeftOver
-       , parseExpr
        ) where
 
-import Graphics.Implicit.Definitions
-import Graphics.Implicit.ExtOpenScad
-import Graphics.Implicit.ExtOpenScad.Definitions
-import Graphics.Implicit.ExtOpenScad.Parser.Expr
-import Text.Parsec.String
-import Text.Parsec.Error
-import Text.ParserCombinators.Parsec  hiding (State)
-import Control.Applicative ((<$>), (<*>), (<*), (*>))
+-- be explicit about where we get things from.
+import Prelude (Bool, String, Either, (<), ($), (.), (<*), otherwise)
+
+-- The datatype of positions in our world.
+import Graphics.Implicit.Definitions (ℝ)
+
+-- The datatype of expressions, symbols, and values in the OpenScad language.
+import Graphics.Implicit.ExtOpenScad.Definitions (Expr(LitE, (:$), Var, ListE, LamE), OVal(ONum, OBool, OString), Pattern)
+
+import Text.ParserCombinators.Parsec (Parser, ParseError, parse, manyTill, anyChar, eof)
+
+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
+
+-- 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)
+
+-- | Types
 
 num :: ℝ -> Expr
 num x
-  -- note that the parser should handle negative number literals
+  -- FIXME: the parser should handle negative number literals
   -- directly, we abstract that deficiency away here
-  | x < 0 = app' "negate" [LitE $ ONum (-x)]
+  | x < 0 = oapp "negate" [LitE $ ONum (-x)]
   | otherwise = LitE $ ONum x
 
 bool :: Bool -> Expr
 bool = LitE . OBool
 
--- Operators and functions need two different kinds of applications
-app :: String -> [Expr] -> Expr
-app name args = Var name :$ [ListE args]
+stringLiteral :: String -> Expr
+stringLiteral = LitE . OString
 
-app' :: Symbol -> [Expr] -> Expr
-app' name args = Var name :$ args
+-- | Operators
+
+plus,minus,mult,modulo,power,divide,negate,and,or,not,gt,lt,ternary,append,index :: [Expr] -> Expr
+minus = oapp "-"
+modulo = oapp "%"
+power = oapp "^"
+divide = oapp "/"
+and = oapp "&&"
+or = oapp "||"
+not = oapp "!"
+gt = oapp ">"
+lt = oapp "<"
+ternary = oapp "?"
+negate = oapp "negate"
+index = oapp "index"
+plus = fapp "+"
+mult = fapp "*"
+append = fapp "++"
+
+-- | we need two different kinds of application functions
+oapp,fapp :: String -> [Expr] -> Expr
+oapp name args = Var name :$ args
+fapp name args = Var name :$ [ListE args]
+
+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) ""
-  where leftOver = manyTill anyToken eof
-
-parseWithEof :: Parser a -> String -> String -> Either ParseError a
-parseWithEof p = parse (p <* eof)
-
-parseExpr :: String -> Either ParseError Expr
-parseExpr = parseWithEof expr0 "expr"
+  where
+    leftOver :: Parser String
+    leftOver = manyTill anyChar eof