diff --git a/Graphics/OpenSCAD.hs b/Graphics/OpenSCAD.hs --- a/Graphics/OpenSCAD.hs +++ b/Graphics/OpenSCAD.hs @@ -88,6 +88,10 @@ three points you get an error. At this time, no tests are done on the faces. That will probably change in the future. +Finally, polygon and polyhedron can generate errors on input that +seems to generate proper solids. If you turn on 'View->Thrown +Together', you'll see it highlighting errors in the object. + Offset is missing even though it's documented, as it isn't supported by a released version of OpenSCAD, so presumably subject to change. It is implemented, but untested as yet. You can add it to the module's @@ -129,27 +133,62 @@ import Data.Colour.Names as Colours import Data.Colour.SRGB (channelRed, channelBlue, channelGreen, toSRGB) import Data.List (elemIndices, nub, intercalate) -import Data.List.NonEmpty (toList) +import qualified Data.List.NonEmpty as NE import Data.Semigroup (Semigroup((<>), sconcat), Monoid(mconcat, mempty, mappend)) +import qualified Data.Set as Set import System.FilePath (FilePath) -- A vector in 2 or 3-space. They are used in transformations of -- 'Model's of their type. -class Vector a where +class Eq a => Vector a where rVector :: a -> String + toList :: a -> [Double] + (#*) :: a -> a -> a -- cross product + (#-) :: a -> a -> a -- difference between two vectors + (#.) :: a -> a -> Double -- dot product + v1 #. v2 = sum $ zipWith (*) (toList v1) (toList v2) + + isZero :: a -> Bool -- is a zero vector. Arguably should use eps. + isZero = all (== 0) . toList + + collinear :: [a] -> Bool -- are all points collinear? + collinear [] = False + collinear [_] = False + collinear [v1, v2] = v1 /= v2 + collinear (v1:v2:vs) + | v1 /= v2 = all (\v -> isZero $ (v2 #- v1) #* (v1 #- v)) vs + | otherwise = collinear (v2:vs) + -- | 'Vector2d' is used where 'Graphics.OpenSCAD' expects an OpenSCAD -- @vector@ of length 2. type Vector2d = (Double, Double) instance Vector Vector2d where rVector (x, y) = "[" ++ show x ++ "," ++ show y ++ "]" + toList (x, y) = [x, y] + (x1, y1) #- (x2, y2) = (x1 - x2, y1 - y2) + (x1, y1) #* (x2, y2) = (0, x1 * y2 - y1 * x2) -- for purposes of collinear -- | 'Vector3d' is used where 'Graphics.OpenSCAD' expects an OpenSCAD -- @vector@ of length 3. type Vector3d = (Double, Double, Double) instance Vector Vector3d where - rVector (a, b, c) = "[" ++ show a ++ "," ++ show b ++ "," ++ show c ++ "]" + rVector (x, y, z) = "[" ++ show x ++ "," ++ show y ++ "," ++ show z ++ "]" + toList (x, y, z) = [x, y, z] + (x1, y1, z1) #- (x2, y2, z2) = (x1 - x2, y1 - y2, z1 - z2) + (x1, y1, z1) #* (x2, y2, z2) = (y1 * z2 - z1 * y2, + z1 * x2 - x1 * z2, + x1 * y2 - y1 * x2) +-- Coplanar only makes sense for R3, so it's not part of the Vector class +coplanar :: [Vector3d] -> Bool +coplanar vs | length vs <= 3 = True -- by definition + | collinear $ take 3 vs = coplanar $ tail vs + | otherwise = + all (\v -> (v3 #- v1) #. ((v2 #- v1) #* (v #- v3)) == 0) vs' + where (v1:v2:v3:vs') = vs + + -- | A 4x4 transformation matrix specifying a complete 3-space -- transform of a 'Model3d'. type TransMatrix = @@ -250,9 +289,12 @@ -- that functions points argument. If you were just going to pass in -- the points, it now needs to be in an extra level of 'List'. polygon :: Int -> [[Vector2d]] -> Model2d -polygon convexity paths = Shape . Polygon convexity points - $ map (concatMap (`elemIndices` points)) paths - where points = nub $ concat paths +polygon convexity paths + | any ((< 3) . length) paths = error "Polygon has fewer than 3 points." + | any collinear paths = error "Points in polygon are collinear." + | otherwise = let points = nub $ concat paths + in Shape . Polygon convexity points + $ map (concatMap (`elemIndices` points)) paths -- | 'offset' a 'Model2d's edges by @offset /delta join/@. offset :: Double -> Join -> Model2d -> Model2d @@ -282,22 +324,47 @@ -- | Turn a list of list of 'Vector3d's and an int into @polyhedron -- /points 'Sides' convexity/@. The argument to polyhedron is the list --- of paths that is the second argument to the OpenSCAD polygon +-- of paths that is the second argument to the OpenSCAD polyhedron -- function, except the points are 'Vector3d's, not the references to -- 'Vector3d's used in that functions @points@ argument. The function -- will build the appropriate function call, using @faces@ if you pass -- in a side that uses more than 3 points, or @triangles@ if not. Note --- that @faces@ doesn't work in older versions of OpenSCAD, an --- @triangles@ is depreciate. Until a mechanism to set the version of +-- that @faces@ doesn't work in older versions of OpenSCAD, and +-- @triangles@ is depreciated. Until a mechanism to set the version of -- OpenSCAD is provided, generating the @faces@ version will cause an -- error. +-- +-- Passing in 'Sides' that have fewer than three points, have +-- collinear points or have points that aren't in the same plane is an +-- error that is caught by the library. polyhedron :: Int -> [[Vector3d]] -> Model3d -polyhedron convexity paths = Solid . Polyhedron convexity points $ sides sin - where points = nub $ concat paths - sin = map (concatMap (`elemIndices` points)) paths - sides ss | any ((> 3) . length) ss = Faces sin - | all ((== 3) . length) ss = Triangles sin - | otherwise = error "All faces must have at least 3 sides." +polyhedron convexity paths + | any ((< 3) . length) paths = error "Some face has fewer than 3 points." + | any collinear paths = error "Some face has collinear points." + | any (not . coplanar) paths = error "Some face isn't coplanar." + | length vectors /= length (nub vectors) = + error "Some faces have different orientation." + | 2 * length edges /= length vectors = error "Some edges are not in two faces." + | xCross headMax xMax tailMax > 0 = + error "Face orientations are counterclockwise." + | otherwise = Solid . Polyhedron convexity points $ sides sidesIn + where vectors = concatMap (\p -> zip p (tail p ++ [head p])) paths + edges = nub $ map (Set.fromList . \(a, b) -> [a, b]) vectors + points = nub $ concat paths + xMax = maximum points + faceMax = head $ filter (elem xMax) paths + (maxFirst, maxLast) = break (== xMax) faceMax + (headMax, tailMax) = (if null maxFirst + then last maxLast + else last maxFirst, + if null (tail maxLast) + then head maxFirst + else head (tail maxLast)) + xCross a b c = (\(a, b, c) -> a) $ (a #- b) #* (b #- c) + sidesIn = map (concatMap (`elemIndices` points)) paths + sides ss | any ((> 3) . length) ss = Faces ss + | all ((== 3) . length) ss = Triangles ss + | otherwise = error "Some faces have fewer than 3 points." -- | Transform a 'Model3d' with a 'TransMatrix' multMatrix :: TransMatrix -> Model3d -> Model3d @@ -530,11 +597,10 @@ -- | Use 'diam' to turn a diameter into a radius for circles, spheres, etc. diam :: Double -> Double diam = (/ 2) - -- Now, let Haskell work it's magic instance Vector v => Semigroup (Model v) where a <> b = union [a, b] - sconcat = union . toList + sconcat = union . NE.toList instance Vector v => Monoid (Model v) where mempty = Solid $ Box 0 0 0 diff --git a/OpenSCAD.cabal b/OpenSCAD.cabal --- a/OpenSCAD.cabal +++ b/OpenSCAD.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: OpenSCAD -version: 0.2.1.1 +version: 0.3.0.0 synopsis: ADT wrapper and renderer for OpenSCAD models. description: An algebraic data type for describing OpenSCAD models, functions to make building such models easier, and @@ -22,24 +22,29 @@ exposed-modules: Graphics.OpenSCAD, Graphics.OpenSCAD.Unicode -- other-modules: other-extensions: UnicodeSyntax - build-depends: base >=4.6 && <4.8, - colour >=2.3 && <2.4, - filepath >=1.3 && <1.4, - semigroups >= 0.15 && < 1.0 + build-depends: base > 4.5 && < 5.0, + colour >=2.3 && < 2.4, + filepath >=1.3 && < 1.4, + semigroups >= 0.15 && < 1.0, + containers >= 0.5 -- hs-source-dirs: default-language: Haskell2010 Test-Suite Units type: exitcode-stdio-1.0 main-is: UnitTest.hs - build-depends: base >=4.6 && <4.8, - colour >=2.3 && <2.4, - filepath >=1.3 && <1.4, - HUnit >=1.2 && <1.4, + build-depends: base > 4.5 && < 5.0, + colour >=2.3, + filepath >=1.3, + HUnit >=1.2, Cabal >= 1.18, - test-framework-hunit >=0.3 && < 0.5, - test-framework >=0.8 && < 1.0, - semigroups >= 0.15 && < 1.0 + tasty-hunit >= 0.9, + tasty >=0.8, + deepseq >= 1.3, + testpack >= 2.1.2.1, + containers >= 0.5.5.1, + semigroups >= 0.15 && < 1.0, + containers >= 0.5 default-language: Haskell2010 source-repository head @@ -47,6 +52,6 @@ location: https://chiselapp.com/user/mwm/repository/OpenSCAD/ source-repository this - type: fossil - location: https://chiselapp.com/user/mwm/repository/OpenSCAD/ - tag: 0.2.1.1 + type: hg + location: https://code.google.com/p/graphics-openscad/ + tag: 0.3.0.0 diff --git a/UnitTest.hs b/UnitTest.hs --- a/UnitTest.hs +++ b/UnitTest.hs @@ -1,19 +1,26 @@ #!/usr/bin/env runghc -module Main where -import Data.Monoid -import Test.HUnit -import Test.Framework -import Test.Framework.Providers.HUnit +module Main where +import Control.DeepSeq +import Control.Exception +import Test.Tasty +import Test.Tasty.HUnit +import Test.HUnit.Tools import Graphics.OpenSCAD import Data.Colour (withOpacity) import Data.List.NonEmpty (fromList) -import Data.Semigroup (sconcat) +import Data.Semigroup (Semigroup((<>), sconcat), Monoid(mconcat, mempty, mappend)) + + +assertError err code = + assertRaises "Check error" (ErrorCall err) . evaluate $ deepseq (show code) () + sw = concat . words -st n e a = testCase n $ (sw e) @=?(sw $ render a) +st n e a = testCase n $ (sw $ render a) @?= (sw e) + {- About the test result values. Running "cabal test" does not verify that the results do the intended @@ -25,29 +32,29 @@ that they are testing does. -} -tests = [ +tests = testGroup "Tests" [ testGroup "3d-primitives" [ testGroup "Spheres" [ - st "1" "sphere(1.0);" (sphere 1 def), + st "1" "sphere(1.0);" $ sphere 1 def, st "2" "sphere(2.0,$fn=100);" (sphere 2 $ fn 100), st "3" "sphere(2.0,$fa=5.0);" (sphere 2 $ fa 5), st "4" "sphere(2.0,$fs=0.1);" (sphere 2 $ fs 0.1) ], testGroup "Boxes" [ - st "box" "cube([1.0,2.0,3.0]);" (box 1 2 3), - st "cube" "cube([2.0,2.0,2.0]);" (cube 2) + st "box" "cube([1.0,2.0,3.0]);" $ box 1 2 3, + st "cube" "cube([2.0,2.0,2.0]);" $ cube 2 ], testGroup "Cylinders" [ - st "1" "cylinder(r=1.0,h=2.0);" (cylinder 1 2 def), + st "1" "cylinder(r=1.0,h=2.0);" $ cylinder 1 2 def, st "2" "cylinder(r=1.0,h=2.0,$fs=0.6);" (cylinder 1 2 $ fs 0.6), st "3" "cylinder(r=1.0,h=2.0,$fn=10);" (cylinder 1 2 $ fn 10), st "4" "cylinder(r=1.0,h=2.0,$fa=30.0);" (cylinder 1 2 $ fa 30) ], testGroup "Oblique-Cylinders" [ - st "1" "cylinder(r1=1.0,h=2.0,r2=2.0);" (obCylinder 1 2 2 def), + st "1" "cylinder(r1=1.0,h=2.0,r2=2.0);" $ obCylinder 1 2 2 def, st "2" "cylinder(r1=1.0,h=2.0,r2=2.0,$fs=0.6);" (obCylinder 1 2 2 $ fs 0.6), st "3" "cylinder(r1=1.0,h=2.0,r2=2.0,$fn=10);" @@ -59,22 +66,21 @@ testGroup "Misc" [ st "import" "import(\"test.stl\");" (solid $ importFile "test.stl"), st "polyhedron 1" - "polyhedron(points=[[10.0,10.0,0.0],[10.0,-10.0,0.0],[0.0,0.0,10.0],[-10.0,-10.0,0.0],[-10.0,10.0,0.0]],triangles=[[0,1,2],[1,3,2],[3,4,2],[4,0,2],[1,0,4],[3,1,4]],convexity=1);" - (polyhedron 1 [[(10, 10, 0), (10, -10, 0), (0, 0, 10)], - [(10, -10, 0), (-10, -10, 0), (0, 0, 10)], - [(-10, -10, 0), (-10, 10, 0), (0, 0, 10)], - [(-10, 10, 0), (10, 10, 0), (0, 0, 10)], - [(10, -10, 0), (10, 10, 0), (-10, 10, 0)], - [(-10, -10, 0), (10, -10, 0), (-10, 10, 0)]]), + "polyhedron(points=[[10.0,10.0,0.0],[10.0,-10.0,0.0],[0.0,0.0,10.0],[-10.0,-10.0,0.0],[-10.0,10.0,0.0]],triangles=[[0,1,2],[1,3,2],[3,4,2],[4,0,2],[1,0,4],[3,1,4]],convexity=1);" $ + polyhedron 1 [[(10, 10, 0), (10, -10, 0), (0, 0, 10)], + [(10, -10, 0), (-10, -10, 0), (0, 0, 10)], + [(-10, -10, 0), (-10, 10, 0), (0, 0, 10)], + [(-10, 10, 0), (10, 10, 0), (0, 0, 10)], + [(10, -10, 0), (10, 10, 0), (-10, 10, 0)], + [(-10, -10, 0), (10, -10, 0), (-10, 10, 0)]], st "polyhedron 2" - "polyhedron(points=[[10.0,10.0,0.0],[10.0,-10.0,0.0],[0.0,0.0,10.0],[-10.0,-10.0,0.0],[-10.0,10.0,0.0]],faces=[[0,1,2],[1,3,2],[3,4,2],[4,0,2],[0,1,3,4]],convexity=1);" - (polyhedron 1 [[(10, 10, 0), (10, -10, 0), (0, 0, 10)], - [(10, -10, 0), (-10, -10, 0), (0, 0, 10)], - [(-10, -10, 0), (-10, 10, 0), (0, 0, 10)], - [(-10, 10, 0), (10, 10, 0), (0, 0, 10)], - [(10, 10, 0), (10, -10, 0), (-10, -10, 0), (-10, 10, 0)]]) + "polyhedron(points=[[10.0,10.0,0.0],[10.0,-10.0,0.0],[0.0,0.0,10.0],[-10.0,-10.0,0.0],[-10.0,10.0,0.0]],faces=[[0,1,2],[1,3,2],[3,4,2],[4,0,2],[4,3,1,0]],convexity=1);" $ + polyhedron 1 [[(10, 10, 0), (10, -10, 0), (0, 0, 10)], + [(10, -10, 0), (-10, -10, 0), (0, 0, 10)], + [(-10, -10, 0), (-10, 10, 0), (0, 0, 10)], + [(-10, 10, 0), (10, 10, 0), (0, 0, 10)], + [(-10, 10, 0), (-10, -10, 0), (10, -10, 0), (10, 10, 0)]] ], - testGroup "Linear-Extrusion" [ st "1" "linear_extrude(height=10.0,twist=0.0,scale=[1.0,1.0],slices=10,convexity=10)circle(1.0);" @@ -113,20 +119,20 @@ ], testGroup "Surface" [ - st "Normal" "surface(file=\"test.dat\",convexity=5);" - (surface "test.dat" False 5), - st "Inverted" "surface(file=\"test.dat\",invert=true,convexity=5);" - (surface "test.dat" True 5) -- Requires 2014.QX + st "Normal" "surface(file=\"test.dat\",convexity=5);" $ + surface "test.dat" False 5, + st "Inverted" "surface(file=\"test.dat\",invert=true,convexity=5);" $ + surface "test.dat" True 5 -- Requires 2014.QX ] ], testGroup "2d-primitives" [ testGroup "Squares" [ - st "rectangle" "square([2.0,3.0]);" (rectangle 2 3), - st "square" "square([2.0,2.0]);" (square 2) + st "rectangle" "square([2.0,3.0]);" $ rectangle 2 3, + st "square" "square([2.0,2.0]);" $ square 2 ], testGroup "Circles" [ - st "1" "circle(1.0);" (circle 1 def), + st "1" "circle(1.0);" $ circle 1 def, st "2" "circle(2.0,$fn=100);" (circle 2 $ fn 100), st "3" "circle(2.0,$fa=5.0);" (circle 2 $ fa 5), st "4" "circle(2.0,$fs=0.1);" (circle 2 $ fs 0.1) @@ -134,8 +140,8 @@ testGroup "Misc" [ st "import" "import(\"test.dxf\");" (solid $ importFile "test.dxf"), st "polygon" - "polygon(points=[[0.0,0.0],[100.0,0.0],[0.0,100.0],[10.0,10.0],[80.0,10.0],[10.0,80.0]],paths=[[0,1,2],[3,4,5]],convexity=10);" - (polygon 10 [[(0,0),(100,0),(0,100)],[(10,10),(80,10),(10,80)]]), + "polygon(points=[[0.0,0.0],[100.0,0.0],[0.0,100.0],[10.0,10.0],[80.0,10.0],[10.0,80.0]],paths=[[0,1,2],[3,4,5]],convexity=10);" $ + polygon 10 [[(0,0),(100,0),(0,100)],[(10,10),(80,10),(10,80)]], st "projection" "projection(cut=false)scale([10.0,10.0,10.0])difference(){translate([0.0,0.0,1.0])cube([1.0,1.0,1.0]);translate([0.25,0.25,0.0])cube([0.5,0.5,3.0]);}" (projection False . scale (10, 10, 10) . difference (up 1 (cube 1)) @@ -207,6 +213,46 @@ (var (fs 0.1) [sphere 2 $ fs 0.1]) ], + testGroup "Errors" [ + testCase "Polygon Pointcount" + . assertError "Polygon has fewer than 3 points." $ + polygon 1 [[(0, 0), (0, 1)]], + testCase "Polygon Linearity" + . assertError "Points in polygon are collinear." $ + polygon 1 [[(0, 0), (0, 1), (0, 2)]], + testCase "Polyhedron Linearity" + . assertError "Some face has collinear points." $ + polyhedron 1 [[(0, 0, 0), (1, 0, 0), (2, 0, 0)]], + testCase "Polyhedron Planarity" . assertError "Some face isn't coplanar." $ + polyhedron 1 [[(10, 10, 0), (10, -10, 0), (0, 10, 10)], + [(10, -10, 0), (-10, -10, 0), (0, 0, 10)], + [(-10, -10, 0), (-10, 10, 0), (0, 0, 10)], + [(-10, 10, 0), (10, 10, 0), (0, 0, 10)], + [(-10, 10, 0), (-10, -10, 0), (10, -10, 0), (0, 0, -10)]], + testCase "Polyhedron Edges" . assertError "Some edges are not in two faces." $ + polyhedron 1 [[(10, 10, 0), (10, -10, 0), (0, 0, 10)], + [(10, -10, 0), (-10, -10, 0), (0, 0, 10)], + [(-10, -10, 0), (-10, 10, 0), (0, 0, 10)], + [(-10, 10, 0), (10, 10, 0), (0, 0, 10)], + [(10, -10, 0), (10, 10, 0), (-10, 10, 0)], + [(-10, -10, 0), (10, -10, 0), (-10, 20, 0)]], + testCase "Polyhedron Faces" + . assertError "Some faces have different orientation." $ + polyhedron 1 [[(10, 10, 0), (10, -10, 0), (0, 0, 10)], + [(10, -10, 0), (-10, -10, 0), (0, 0, 10)], + [(-10, -10, 0), (-10, 10, 0), (0, 0, 10)], + [(-10, 10, 0), (10, 10, 0), (0, 0, 10)], + [(10, -10, 0), (10, 10, 0), (-10, 10, 0)], + [(10, -10, 0), (-10, -10, 0), (-10, 10, 0)]], + testCase "Polyhedron Orientation" + . assertError "Face orientations are counterclockwise." $ + polyhedron 1 [[(10, -10, 0), (10, 10, 0), (0, 0, 10)], + [(-10, -10, 0), (10, -10, 0), (0, 0, 10)], + [(-10, 10, 0), (-10, -10, 0), (0, 0, 10)], + [(10, 10, 0), (-10, 10, 0), (0, 0, 10)], + [(10, 10, 0), (10, -10, 0), (-10, 10, 0)], + [(10, -10, 0), (-10, -10, 0), (-10, 10, 0)]] + ], testGroup "Combinations" [ st "union" "union(){cube([1.0,1.0,1.0]);sphere(1.1,$fs=0.1);}"