From 000641ad447f7b841157cf02386edfdd368ab1ea Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 2 Sep 2011 09:09:23 -0400 Subject: [PATCH 01/16] Limit the size of arbitrary Values3D, and prevent empty dimensions. --- src/Values.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Values.hs b/src/Values.hs index dab9e34..8e2b61e 100644 --- a/src/Values.hs +++ b/src/Values.hs @@ -20,7 +20,7 @@ import Data.Array.Repa ( import Data.Array.Repa.IO.Vector (readVectorFromTextFile, writeVectorToTextFile) import System.FilePath () -import Test.QuickCheck (Arbitrary(..), Gen, Positive(..), vectorOf) +import Test.QuickCheck (Arbitrary(..), Gen, choose, vectorOf) import ScaleFactor @@ -33,9 +33,10 @@ type Values3D = Array DIM3 Double instance Arbitrary Values3D where arbitrary = do - (Positive x_dim) <- arbitrary :: Gen (Positive Int) - (Positive y_dim) <- arbitrary :: Gen (Positive Int) - (Positive z_dim) <- arbitrary :: Gen (Positive Int) + -- I declare not to care about empty lists. + x_dim <- choose (1, 27) + y_dim <- choose (1, 27) + z_dim <- choose (1, 27) elements <- vectorOf (x_dim * y_dim * z_dim) (arbitrary :: Gen Double) let new_shape = (Z :. x_dim :. y_dim :. z_dim) let three_d = Data.Array.Repa.fromList new_shape elements -- 2.44.2 From 29ffefd3c892f38eee96fdd672ceab4d0454cd90 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 2 Sep 2011 09:13:55 -0400 Subject: [PATCH 02/16] Add another guard on calculate_containing_cube_coordinate. --- src/Grid.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Grid.hs b/src/Grid.hs index 8bf8382..7325d2b 100644 --- a/src/Grid.hs +++ b/src/Grid.hs @@ -96,6 +96,7 @@ calculate_containing_cube_coordinate g coord -- returns cube #1 if we would have returned cube #0 and cube #1 -- exists. | coord == offset && (xsize > 0 && ysize > 0 && zsize > 0) = 1 + | coord < offset = 0 | otherwise = (ceiling ( (coord + offset) / cube_width )) - 1 where (xsize, ysize, zsize) = dims (function_values g) -- 2.44.2 From ae48be1ae233be1bd3632a63febecd3ea7af1f61 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 2 Sep 2011 09:15:12 -0400 Subject: [PATCH 03/16] Make test_trilinear9x9x9_reproduced slow again. Add a new failing test: prop_cube_indices_never_go_out_of_bounds. --- src/Tests/Grid.hs | 36 +++++++++++++++++++++++++++++++++--- 1 file changed, 33 insertions(+), 3 deletions(-) diff --git a/src/Tests/Grid.hs b/src/Tests/Grid.hs index 53b4683..a8bc685 100644 --- a/src/Tests/Grid.hs +++ b/src/Tests/Grid.hs @@ -4,6 +4,8 @@ where import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit +import Test.QuickCheck + import Assertions import Comparisons @@ -14,6 +16,7 @@ import Grid import Point (Point) import Tetrahedron import ThreeDimensional +import Values (dims) -- | Check all coefficients of tetrahedron0 belonging to the cube @@ -191,8 +194,6 @@ test_zeros_reproduced = -- | Make sure we can reproduce a 9x9x9 trilinear from the 3x3x3 one. --- Use (t <- tetrahedra c0) for a much slower but comprehensive --- test. test_trilinear9x9x9_reproduced :: Assertion test_trilinear9x9x9_reproduced = assertTrue "trilinear 9x9x9 is reproduced correctly" $ @@ -200,7 +201,7 @@ test_trilinear9x9x9_reproduced = | i <- [0..8], j <- [0..8], k <- [0..8], - t <- [head $ tetrahedra c0], + t <- tetrahedra c0, let p = polynomial t, let i' = (fromIntegral i) * 0.5, let j' = (fromIntegral j) * 0.5, @@ -228,3 +229,32 @@ test_tetrahedra_collision_sensitivity = c = cube_at g 0 17 1 p = (0, 16.75, 0.5) :: Point t15 = tetrahedron15 c + + +prop_cube_indices_never_go_out_of_bounds :: Grid -> Gen Bool +prop_cube_indices_never_go_out_of_bounds g = + do + let delta = Grid.h g + let coordmin = negate (delta/2) + + let (xsize, ysize, zsize) = dims $ function_values g + let xmax = delta*(fromIntegral xsize) - (delta/2) + let ymax = delta*(fromIntegral ysize) - (delta/2) + let zmax = delta*(fromIntegral zsize) - (delta/2) + + x <- choose (coordmin, xmax) + y <- choose (coordmin, ymax) + z <- choose (coordmin, zmax) + + let p = (x,y,z) :: Point + let idx_x = calculate_containing_cube_coordinate g x + let idx_y = calculate_containing_cube_coordinate g y + let idx_z = calculate_containing_cube_coordinate g z + + return $ + idx_x >= 0 && + idx_x <= xsize - 1 && + idx_y >= 0 && + idx_y <= ysize - 1 && + idx_z >= 0 && + idx_z <= zsize - 1 -- 2.44.2 From 70120aad0e7b2126b81e8d444fd7591c4badd45f Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 2 Sep 2011 09:16:16 -0400 Subject: [PATCH 04/16] Add a new test group, slow_tests, that is run after all of the others. --- test/TestSuite.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 82e2870..66f592b 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -41,8 +41,7 @@ grid_tests = tc "tetrahedra collision test isn't too sensitive" test_tetrahedra_collision_sensitivity, tc "trilinear reproduced" test_trilinear_reproduced, - tc "zeros reproduced" test_zeros_reproduced, - tc "trilinear9x9x9 reproduced" test_trilinear9x9x9_reproduced ] + tc "zeros reproduced" test_zeros_reproduced ] misc_tests :: Test.Framework.Test @@ -206,7 +205,16 @@ tetrahedron_properties = tp "y rotation doesn't affect right" prop_y_rotation_doesnt_affect_right, tp "z rotation doesn't affect top" prop_z_rotation_doesnt_affect_top, tp "z rotation doesn't affect down" prop_z_rotation_doesnt_affect_down ] - + + +-- Do the slow tests last so we can stop paying attention. +slow_tests :: Test.Framework.Test +slow_tests = + testGroup "Slow Tests" [ + tp "cube indices within bounds" prop_cube_indices_never_go_out_of_bounds, + tc "trilinear9x9x9 reproduced" test_trilinear9x9x9_reproduced ] + + tests :: [Test.Framework.Test] tests = [ cardinal_tests, function_values_tests, @@ -222,4 +230,5 @@ tests = [ cardinal_tests, -- p78_25_properties, p79_26_properties, p79_27_properties, - p79_28_properties ] + p79_28_properties, + slow_tests ] -- 2.44.2 From 3d197ab1a23d654d60617db6559daed195f1e016 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 2 Sep 2011 09:34:42 -0400 Subject: [PATCH 05/16] Attempt to use precomputed volumes everywhere, tests fail en masse. --- src/Cube.hs | 61 ++++++++++++++++++++++------------------ src/Grid.hs | 5 +++- src/Tests/Tetrahedron.hs | 18 ++++++++---- src/Tetrahedron.hs | 16 ++++++----- 4 files changed, 59 insertions(+), 41 deletions(-) diff --git a/src/Cube.hs b/src/Cube.hs index 0122aea..077fbbc 100644 --- a/src/Cube.hs +++ b/src/Cube.hs @@ -15,7 +15,8 @@ data Cube = Cube { h :: Double, i :: Int, j :: Int, k :: Int, - fv :: FunctionValues } + fv :: FunctionValues, + tetrahedra_volume :: Double } deriving (Eq) @@ -26,7 +27,8 @@ instance Arbitrary Cube where j' <- choose (coordmin, coordmax) k' <- choose (coordmin, coordmax) fv' <- arbitrary :: Gen FunctionValues - return (Cube h' i' j' k' fv') + (Positive tet_vol) <- arbitrary :: Gen (Positive Double) + return (Cube h' i' j' k' fv' tet_vol) where coordmin = -268435456 -- -(2^29 / 2) coordmax = 268435456 -- +(2^29 / 2) @@ -51,7 +53,7 @@ instance Show Cube where -- | Returns an empty 'Cube'. empty_cube :: Cube -empty_cube = Cube 0 0 0 0 empty_values +empty_cube = Cube 0 0 0 0 empty_values 0 -- | The left-side boundary of the cube. See Sorokina and Zeilfelder, @@ -197,9 +199,14 @@ right_face c = Face.Face v0' v1' v2' v3' v3' = (center c) + (-delta, delta, -delta) +make_tetrahedron :: Cube -> Point -> Point -> Point -> Point -> Tetrahedron +make_tetrahedron c v0 v1 v2 v3 = + Tetrahedron (Cube.fv c) v0 v1 v2 v3 (tetrahedra_volume c) + + tetrahedron0 :: Cube -> Tetrahedron tetrahedron0 c = - Tetrahedron (Cube.fv c) v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) @@ -208,7 +215,7 @@ tetrahedron0 c = tetrahedron1 :: Cube -> Tetrahedron tetrahedron1 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) @@ -218,7 +225,7 @@ tetrahedron1 c = tetrahedron2 :: Cube -> Tetrahedron tetrahedron2 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) @@ -228,7 +235,7 @@ tetrahedron2 c = tetrahedron3 :: Cube -> Tetrahedron tetrahedron3 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) @@ -238,7 +245,7 @@ tetrahedron3 c = tetrahedron4 :: Cube -> Tetrahedron tetrahedron4 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) @@ -248,7 +255,7 @@ tetrahedron4 c = tetrahedron5 :: Cube -> Tetrahedron tetrahedron5 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) @@ -258,7 +265,7 @@ tetrahedron5 c = tetrahedron6 :: Cube -> Tetrahedron tetrahedron6 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) @@ -270,7 +277,7 @@ tetrahedron6 c = tetrahedron7 :: Cube -> Tetrahedron tetrahedron7 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) @@ -280,7 +287,7 @@ tetrahedron7 c = tetrahedron8 :: Cube -> Tetrahedron tetrahedron8 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (back_face c) @@ -290,7 +297,7 @@ tetrahedron8 c = tetrahedron9 :: Cube -> Tetrahedron tetrahedron9 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (back_face c) @@ -302,7 +309,7 @@ tetrahedron9 c = tetrahedron10 :: Cube -> Tetrahedron tetrahedron10 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (back_face c) @@ -316,7 +323,7 @@ tetrahedron10 c = tetrahedron11 :: Cube -> Tetrahedron tetrahedron11 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (back_face c) @@ -329,7 +336,7 @@ tetrahedron11 c = tetrahedron12 :: Cube -> Tetrahedron tetrahedron12 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (down_face c) @@ -340,7 +347,7 @@ tetrahedron12 c = tetrahedron13 :: Cube -> Tetrahedron tetrahedron13 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (down_face c) @@ -351,7 +358,7 @@ tetrahedron13 c = tetrahedron14 :: Cube -> Tetrahedron tetrahedron14 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (down_face c) @@ -364,7 +371,7 @@ tetrahedron14 c = tetrahedron15 :: Cube -> Tetrahedron tetrahedron15 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (down_face c) @@ -375,7 +382,7 @@ tetrahedron15 c = tetrahedron16 :: Cube -> Tetrahedron tetrahedron16 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (right_face c) @@ -386,7 +393,7 @@ tetrahedron16 c = tetrahedron17 :: Cube -> Tetrahedron tetrahedron17 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (right_face c) @@ -397,7 +404,7 @@ tetrahedron17 c = tetrahedron18 :: Cube -> Tetrahedron tetrahedron18 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (right_face c) @@ -410,7 +417,7 @@ tetrahedron18 c = tetrahedron19 :: Cube -> Tetrahedron tetrahedron19 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (right_face c) @@ -422,7 +429,7 @@ tetrahedron19 c = tetrahedron20 :: Cube -> Tetrahedron tetrahedron20 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (left_face c) @@ -433,7 +440,7 @@ tetrahedron20 c = tetrahedron21 :: Cube -> Tetrahedron tetrahedron21 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (left_face c) @@ -444,7 +451,7 @@ tetrahedron21 c = tetrahedron22 :: Cube -> Tetrahedron tetrahedron22 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (left_face c) @@ -457,7 +464,7 @@ tetrahedron22 c = tetrahedron23 :: Cube -> Tetrahedron tetrahedron23 c = - Tetrahedron fv' v0' v1' v2' v3' + make_tetrahedron c v0' v1' v2' v3' where v0' = center c v1' = center (left_face c) diff --git a/src/Grid.hs b/src/Grid.hs index 7325d2b..435f095 100644 --- a/src/Grid.hs +++ b/src/Grid.hs @@ -57,7 +57,10 @@ cubes g | i <- [0..xmax], j <- [0..ymax], k <- [0..zmax], - let cube_ijk = Cube (h g) i j k (make_values fvs i j k)] + let delta = h g, + let tet_vol = (1/24)*(delta^(3::Int)), + let cube_ijk = + Cube delta i j k (make_values fvs i j k) tet_vol] where xmax = xsize - 1 ymax = ysize - 1 diff --git a/src/Tests/Tetrahedron.hs b/src/Tests/Tetrahedron.hs index 8f83808..3b511d2 100644 --- a/src/Tests/Tetrahedron.hs +++ b/src/Tests/Tetrahedron.hs @@ -34,7 +34,8 @@ tetrahedron1_geometry_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values } + fv = empty_values, + precomputed_volume = 0 } volume1 :: Assertion volume1 = @@ -68,7 +69,8 @@ tetrahedron2_geometry_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values } + fv = empty_values, + precomputed_volume = 0 } volume1 :: Assertion volume1 = assertEqual "volume1 is correct" True (vol ~= (1/3)) @@ -106,7 +108,8 @@ containment_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values } + fv = empty_values, + precomputed_volume = 0 } contained = contains_point t exterior_point @@ -120,7 +123,8 @@ containment_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values } + fv = empty_values, + precomputed_volume = 0 } contained = contains_point t exterior_point @@ -134,7 +138,8 @@ containment_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values } + fv = empty_values, + precomputed_volume = 0 } contained = contains_point t exterior_point @@ -148,7 +153,8 @@ containment_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values } + fv = empty_values, + precomputed_volume = 0 } contained = contains_point t exterior_point diff --git a/src/Tetrahedron.hs b/src/Tetrahedron.hs index 95233e0..4606761 100644 --- a/src/Tetrahedron.hs +++ b/src/Tetrahedron.hs @@ -3,7 +3,7 @@ where import Numeric.LinearAlgebra hiding (i, scale) import Prelude hiding (LT) -import Test.QuickCheck (Arbitrary(..), Gen) +import Test.QuickCheck (Arbitrary(..), Gen, Positive(..)) import Cardinal import Comparisons (nearly_ge) @@ -17,7 +17,8 @@ data Tetrahedron = Tetrahedron { fv :: FunctionValues, v0 :: Point, v1 :: Point, v2 :: Point, - v3 :: Point } + v3 :: Point, + precomputed_volume :: Double } deriving (Eq) @@ -28,7 +29,8 @@ instance Arbitrary Tetrahedron where rnd_v2 <- arbitrary :: Gen Point rnd_v3 <- arbitrary :: Gen Point rnd_fv <- arbitrary :: Gen FunctionValues - return (Tetrahedron rnd_fv rnd_v0 rnd_v1 rnd_v2 rnd_v3) + (Positive rnd_vol) <- arbitrary :: Gen (Positive Double) + return (Tetrahedron rnd_fv rnd_v0 rnd_v1 rnd_v2 rnd_v3 rnd_vol) instance Show Tetrahedron where @@ -265,27 +267,27 @@ volume t -- | The barycentric coordinates of a point with respect to v0. b0 :: Tetrahedron -> (RealFunction Point) -b0 t point = (volume inner_tetrahedron) / (volume t) +b0 t point = (volume inner_tetrahedron) / (precomputed_volume t) where inner_tetrahedron = t { v0 = point } -- | The barycentric coordinates of a point with respect to v1. b1 :: Tetrahedron -> (RealFunction Point) -b1 t point = (volume inner_tetrahedron) / (volume t) +b1 t point = (volume inner_tetrahedron) / (precomputed_volume t) where inner_tetrahedron = t { v1 = point } -- | The barycentric coordinates of a point with respect to v2. b2 :: Tetrahedron -> (RealFunction Point) -b2 t point = (volume inner_tetrahedron) / (volume t) +b2 t point = (volume inner_tetrahedron) / (precomputed_volume t) where inner_tetrahedron = t { v2 = point } -- | The barycentric coordinates of a point with respect to v3. b3 :: Tetrahedron -> (RealFunction Point) -b3 t point = (volume inner_tetrahedron) / (volume t) +b3 t point = (volume inner_tetrahedron) / (precomputed_volume t) where inner_tetrahedron = t { v3 = point } -- 2.44.2 From c4701eee43e313f634d3d76faee681ff28d76b72 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 2 Sep 2011 10:35:06 -0400 Subject: [PATCH 06/16] Revert "Attempt to use precomputed volumes everywhere, tests fail en masse." This reverts commit ffc644b4eaf951619bfe59a2050f455814263cb2. --- src/Cube.hs | 61 ++++++++++++++++++---------------------- src/Grid.hs | 5 +--- src/Tests/Tetrahedron.hs | 18 ++++-------- src/Tetrahedron.hs | 16 +++++------ 4 files changed, 41 insertions(+), 59 deletions(-) diff --git a/src/Cube.hs b/src/Cube.hs index 077fbbc..0122aea 100644 --- a/src/Cube.hs +++ b/src/Cube.hs @@ -15,8 +15,7 @@ data Cube = Cube { h :: Double, i :: Int, j :: Int, k :: Int, - fv :: FunctionValues, - tetrahedra_volume :: Double } + fv :: FunctionValues } deriving (Eq) @@ -27,8 +26,7 @@ instance Arbitrary Cube where j' <- choose (coordmin, coordmax) k' <- choose (coordmin, coordmax) fv' <- arbitrary :: Gen FunctionValues - (Positive tet_vol) <- arbitrary :: Gen (Positive Double) - return (Cube h' i' j' k' fv' tet_vol) + return (Cube h' i' j' k' fv') where coordmin = -268435456 -- -(2^29 / 2) coordmax = 268435456 -- +(2^29 / 2) @@ -53,7 +51,7 @@ instance Show Cube where -- | Returns an empty 'Cube'. empty_cube :: Cube -empty_cube = Cube 0 0 0 0 empty_values 0 +empty_cube = Cube 0 0 0 0 empty_values -- | The left-side boundary of the cube. See Sorokina and Zeilfelder, @@ -199,14 +197,9 @@ right_face c = Face.Face v0' v1' v2' v3' v3' = (center c) + (-delta, delta, -delta) -make_tetrahedron :: Cube -> Point -> Point -> Point -> Point -> Tetrahedron -make_tetrahedron c v0 v1 v2 v3 = - Tetrahedron (Cube.fv c) v0 v1 v2 v3 (tetrahedra_volume c) - - tetrahedron0 :: Cube -> Tetrahedron tetrahedron0 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron (Cube.fv c) v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) @@ -215,7 +208,7 @@ tetrahedron0 c = tetrahedron1 :: Cube -> Tetrahedron tetrahedron1 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) @@ -225,7 +218,7 @@ tetrahedron1 c = tetrahedron2 :: Cube -> Tetrahedron tetrahedron2 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) @@ -235,7 +228,7 @@ tetrahedron2 c = tetrahedron3 :: Cube -> Tetrahedron tetrahedron3 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) @@ -245,7 +238,7 @@ tetrahedron3 c = tetrahedron4 :: Cube -> Tetrahedron tetrahedron4 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) @@ -255,7 +248,7 @@ tetrahedron4 c = tetrahedron5 :: Cube -> Tetrahedron tetrahedron5 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) @@ -265,7 +258,7 @@ tetrahedron5 c = tetrahedron6 :: Cube -> Tetrahedron tetrahedron6 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) @@ -277,7 +270,7 @@ tetrahedron6 c = tetrahedron7 :: Cube -> Tetrahedron tetrahedron7 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) @@ -287,7 +280,7 @@ tetrahedron7 c = tetrahedron8 :: Cube -> Tetrahedron tetrahedron8 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (back_face c) @@ -297,7 +290,7 @@ tetrahedron8 c = tetrahedron9 :: Cube -> Tetrahedron tetrahedron9 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (back_face c) @@ -309,7 +302,7 @@ tetrahedron9 c = tetrahedron10 :: Cube -> Tetrahedron tetrahedron10 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (back_face c) @@ -323,7 +316,7 @@ tetrahedron10 c = tetrahedron11 :: Cube -> Tetrahedron tetrahedron11 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (back_face c) @@ -336,7 +329,7 @@ tetrahedron11 c = tetrahedron12 :: Cube -> Tetrahedron tetrahedron12 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (down_face c) @@ -347,7 +340,7 @@ tetrahedron12 c = tetrahedron13 :: Cube -> Tetrahedron tetrahedron13 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (down_face c) @@ -358,7 +351,7 @@ tetrahedron13 c = tetrahedron14 :: Cube -> Tetrahedron tetrahedron14 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (down_face c) @@ -371,7 +364,7 @@ tetrahedron14 c = tetrahedron15 :: Cube -> Tetrahedron tetrahedron15 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (down_face c) @@ -382,7 +375,7 @@ tetrahedron15 c = tetrahedron16 :: Cube -> Tetrahedron tetrahedron16 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (right_face c) @@ -393,7 +386,7 @@ tetrahedron16 c = tetrahedron17 :: Cube -> Tetrahedron tetrahedron17 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (right_face c) @@ -404,7 +397,7 @@ tetrahedron17 c = tetrahedron18 :: Cube -> Tetrahedron tetrahedron18 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (right_face c) @@ -417,7 +410,7 @@ tetrahedron18 c = tetrahedron19 :: Cube -> Tetrahedron tetrahedron19 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (right_face c) @@ -429,7 +422,7 @@ tetrahedron19 c = tetrahedron20 :: Cube -> Tetrahedron tetrahedron20 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (left_face c) @@ -440,7 +433,7 @@ tetrahedron20 c = tetrahedron21 :: Cube -> Tetrahedron tetrahedron21 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (left_face c) @@ -451,7 +444,7 @@ tetrahedron21 c = tetrahedron22 :: Cube -> Tetrahedron tetrahedron22 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (left_face c) @@ -464,7 +457,7 @@ tetrahedron22 c = tetrahedron23 :: Cube -> Tetrahedron tetrahedron23 c = - make_tetrahedron c v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (left_face c) diff --git a/src/Grid.hs b/src/Grid.hs index 435f095..7325d2b 100644 --- a/src/Grid.hs +++ b/src/Grid.hs @@ -57,10 +57,7 @@ cubes g | i <- [0..xmax], j <- [0..ymax], k <- [0..zmax], - let delta = h g, - let tet_vol = (1/24)*(delta^(3::Int)), - let cube_ijk = - Cube delta i j k (make_values fvs i j k) tet_vol] + let cube_ijk = Cube (h g) i j k (make_values fvs i j k)] where xmax = xsize - 1 ymax = ysize - 1 diff --git a/src/Tests/Tetrahedron.hs b/src/Tests/Tetrahedron.hs index 3b511d2..8f83808 100644 --- a/src/Tests/Tetrahedron.hs +++ b/src/Tests/Tetrahedron.hs @@ -34,8 +34,7 @@ tetrahedron1_geometry_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values, - precomputed_volume = 0 } + fv = empty_values } volume1 :: Assertion volume1 = @@ -69,8 +68,7 @@ tetrahedron2_geometry_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values, - precomputed_volume = 0 } + fv = empty_values } volume1 :: Assertion volume1 = assertEqual "volume1 is correct" True (vol ~= (1/3)) @@ -108,8 +106,7 @@ containment_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values, - precomputed_volume = 0 } + fv = empty_values } contained = contains_point t exterior_point @@ -123,8 +120,7 @@ containment_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values, - precomputed_volume = 0 } + fv = empty_values } contained = contains_point t exterior_point @@ -138,8 +134,7 @@ containment_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values, - precomputed_volume = 0 } + fv = empty_values } contained = contains_point t exterior_point @@ -153,8 +148,7 @@ containment_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values, - precomputed_volume = 0 } + fv = empty_values } contained = contains_point t exterior_point diff --git a/src/Tetrahedron.hs b/src/Tetrahedron.hs index 4606761..95233e0 100644 --- a/src/Tetrahedron.hs +++ b/src/Tetrahedron.hs @@ -3,7 +3,7 @@ where import Numeric.LinearAlgebra hiding (i, scale) import Prelude hiding (LT) -import Test.QuickCheck (Arbitrary(..), Gen, Positive(..)) +import Test.QuickCheck (Arbitrary(..), Gen) import Cardinal import Comparisons (nearly_ge) @@ -17,8 +17,7 @@ data Tetrahedron = Tetrahedron { fv :: FunctionValues, v0 :: Point, v1 :: Point, v2 :: Point, - v3 :: Point, - precomputed_volume :: Double } + v3 :: Point } deriving (Eq) @@ -29,8 +28,7 @@ instance Arbitrary Tetrahedron where rnd_v2 <- arbitrary :: Gen Point rnd_v3 <- arbitrary :: Gen Point rnd_fv <- arbitrary :: Gen FunctionValues - (Positive rnd_vol) <- arbitrary :: Gen (Positive Double) - return (Tetrahedron rnd_fv rnd_v0 rnd_v1 rnd_v2 rnd_v3 rnd_vol) + return (Tetrahedron rnd_fv rnd_v0 rnd_v1 rnd_v2 rnd_v3) instance Show Tetrahedron where @@ -267,27 +265,27 @@ volume t -- | The barycentric coordinates of a point with respect to v0. b0 :: Tetrahedron -> (RealFunction Point) -b0 t point = (volume inner_tetrahedron) / (precomputed_volume t) +b0 t point = (volume inner_tetrahedron) / (volume t) where inner_tetrahedron = t { v0 = point } -- | The barycentric coordinates of a point with respect to v1. b1 :: Tetrahedron -> (RealFunction Point) -b1 t point = (volume inner_tetrahedron) / (precomputed_volume t) +b1 t point = (volume inner_tetrahedron) / (volume t) where inner_tetrahedron = t { v1 = point } -- | The barycentric coordinates of a point with respect to v2. b2 :: Tetrahedron -> (RealFunction Point) -b2 t point = (volume inner_tetrahedron) / (precomputed_volume t) +b2 t point = (volume inner_tetrahedron) / (volume t) where inner_tetrahedron = t { v2 = point } -- | The barycentric coordinates of a point with respect to v3. b3 :: Tetrahedron -> (RealFunction Point) -b3 t point = (volume inner_tetrahedron) / (precomputed_volume t) +b3 t point = (volume inner_tetrahedron) / (volume t) where inner_tetrahedron = t { v3 = point } -- 2.44.2 From 2da1ed2fd5929baa129812632068540a3c38a253 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 2 Sep 2011 10:47:06 -0400 Subject: [PATCH 07/16] Begin writing the precomputed_volume feature again. --- src/Cube.hs | 72 ++++++++++++++++++++++++++++++---------------- src/Tetrahedron.hs | 6 ++-- 2 files changed, 52 insertions(+), 26 deletions(-) diff --git a/src/Cube.hs b/src/Cube.hs index 0122aea..1e83a3e 100644 --- a/src/Cube.hs +++ b/src/Cube.hs @@ -199,66 +199,72 @@ right_face c = Face.Face v0' v1' v2' v3' tetrahedron0 :: Cube -> Tetrahedron tetrahedron0 c = - Tetrahedron (Cube.fv c) v0' v1' v2' v3' + Tetrahedron (Cube.fv c) v0' v1' v2' v3' vol where v0' = center c v1' = center (front_face c) v2' = Face.v0 (front_face c) v3' = Face.v1 (front_face c) + vol = 0 tetrahedron1 :: Cube -> Tetrahedron tetrahedron1 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (front_face c) v2' = Face.v1 (front_face c) v3' = Face.v2 (front_face c) fv' = rotate ccwx (Cube.fv c) + vol = 0 tetrahedron2 :: Cube -> Tetrahedron tetrahedron2 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (front_face c) v2' = Face.v2 (front_face c) v3' = Face.v3 (front_face c) fv' = rotate ccwx $ rotate ccwx $ Cube.fv c + vol = 0 tetrahedron3 :: Cube -> Tetrahedron tetrahedron3 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (front_face c) v2' = Face.v3 (front_face c) v3' = Face.v0 (front_face c) fv' = rotate cwx (Cube.fv c) + vol = 0 tetrahedron4 :: Cube -> Tetrahedron tetrahedron4 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (top_face c) v2' = Face.v0 (top_face c) v3' = Face.v1 (top_face c) fv' = rotate cwy (Cube.fv c) + vol = 0 tetrahedron5 :: Cube -> Tetrahedron tetrahedron5 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (top_face c) v2' = Face.v1 (top_face c) v3' = Face.v2 (top_face c) fv' = rotate cwy $ rotate cwz $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron6 :: Cube -> Tetrahedron tetrahedron6 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (top_face c) @@ -267,30 +273,33 @@ tetrahedron6 c = fv' = rotate cwy $ rotate cwz $ rotate cwz $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron7 :: Cube -> Tetrahedron tetrahedron7 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (top_face c) v2' = Face.v3 (top_face c) v3' = Face.v0 (top_face c) fv' = rotate cwy $ rotate ccwz $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron8 :: Cube -> Tetrahedron tetrahedron8 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (back_face c) v2' = Face.v0 (back_face c) v3' = Face.v1 (back_face c) fv' = rotate cwy $ rotate cwy $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron9 :: Cube -> Tetrahedron tetrahedron9 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (back_face c) @@ -299,10 +308,11 @@ tetrahedron9 c = fv' = rotate cwy $ rotate cwy $ rotate cwx $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron10 :: Cube -> Tetrahedron tetrahedron10 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (back_face c) @@ -313,10 +323,11 @@ tetrahedron10 c = $ rotate cwx $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron11 :: Cube -> Tetrahedron tetrahedron11 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (back_face c) @@ -325,33 +336,36 @@ tetrahedron11 c = fv' = rotate cwy $ rotate cwy $ rotate ccwx $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron12 :: Cube -> Tetrahedron tetrahedron12 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (down_face c) v2' = Face.v0 (down_face c) v3' = Face.v1 (down_face c) fv' = rotate ccwy (Tetrahedron.fv (tetrahedron0 c)) + vol = 0 tetrahedron13 :: Cube -> Tetrahedron tetrahedron13 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (down_face c) v2' = Face.v1 (down_face c) v3' = Face.v2 (down_face c) fv' = rotate ccwy $ rotate ccwz $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron14 :: Cube -> Tetrahedron tetrahedron14 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (down_face c) @@ -360,44 +374,48 @@ tetrahedron14 c = fv' = rotate ccwy $ rotate ccwz $ rotate ccwz $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron15 :: Cube -> Tetrahedron tetrahedron15 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (down_face c) v2' = Face.v3 (down_face c) v3' = Face.v0 (down_face c) fv' = rotate ccwy $ rotate cwz $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron16 :: Cube -> Tetrahedron tetrahedron16 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (right_face c) v2' = Face.v0 (right_face c) v3' = Face.v1 (right_face c) fv' = rotate ccwz (Tetrahedron.fv (tetrahedron0 c)) + vol = 0 tetrahedron17 :: Cube -> Tetrahedron tetrahedron17 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (right_face c) v2' = Face.v1 (right_face c) v3' = Face.v2 (right_face c) fv' = rotate ccwz $ rotate cwy $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron18 :: Cube -> Tetrahedron tetrahedron18 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (right_face c) @@ -406,11 +424,12 @@ tetrahedron18 c = fv' = rotate ccwz $ rotate cwy $ rotate cwy $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron19 :: Cube -> Tetrahedron tetrahedron19 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (right_face c) @@ -418,33 +437,36 @@ tetrahedron19 c = v3' = Face.v0 (right_face c) fv' = rotate ccwz $ rotate ccwy $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron20 :: Cube -> Tetrahedron tetrahedron20 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (left_face c) v2' = Face.v0 (left_face c) v3' = Face.v1 (left_face c) fv' = rotate cwz (Tetrahedron.fv (tetrahedron0 c)) + vol = 0 tetrahedron21 :: Cube -> Tetrahedron tetrahedron21 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (left_face c) v2' = Face.v1 (left_face c) v3' = Face.v2 (left_face c) fv' = rotate cwz $ rotate ccwy $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron22 :: Cube -> Tetrahedron tetrahedron22 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (left_face c) @@ -453,11 +475,12 @@ tetrahedron22 c = fv' = rotate cwz $ rotate ccwy $ rotate ccwy $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedron23 :: Cube -> Tetrahedron tetrahedron23 c = - Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' vol where v0' = center c v1' = center (left_face c) @@ -465,6 +488,7 @@ tetrahedron23 c = v3' = Face.v0 (left_face c) fv' = rotate cwz $ rotate cwy $ Tetrahedron.fv (tetrahedron0 c) + vol = 0 tetrahedra :: Cube -> [Tetrahedron] diff --git a/src/Tetrahedron.hs b/src/Tetrahedron.hs index 95233e0..eef1656 100644 --- a/src/Tetrahedron.hs +++ b/src/Tetrahedron.hs @@ -17,7 +17,8 @@ data Tetrahedron = Tetrahedron { fv :: FunctionValues, v0 :: Point, v1 :: Point, v2 :: Point, - v3 :: Point } + v3 :: Point, + precomputed_volume :: Double } deriving (Eq) @@ -28,7 +29,8 @@ instance Arbitrary Tetrahedron where rnd_v2 <- arbitrary :: Gen Point rnd_v3 <- arbitrary :: Gen Point rnd_fv <- arbitrary :: Gen FunctionValues - return (Tetrahedron rnd_fv rnd_v0 rnd_v1 rnd_v2 rnd_v3) + rnd_vol <- arbitrary :: Gen Double + return (Tetrahedron rnd_fv rnd_v0 rnd_v1 rnd_v2 rnd_v3 rnd_vol) instance Show Tetrahedron where -- 2.44.2 From f902a4d6b47c61ac1ce06ae837d94bda9d2471be Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 2 Sep 2011 10:48:40 -0400 Subject: [PATCH 08/16] Fix a few test warnings. --- src/Tests/Tetrahedron.hs | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/src/Tests/Tetrahedron.hs b/src/Tests/Tetrahedron.hs index 8f83808..3b511d2 100644 --- a/src/Tests/Tetrahedron.hs +++ b/src/Tests/Tetrahedron.hs @@ -34,7 +34,8 @@ tetrahedron1_geometry_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values } + fv = empty_values, + precomputed_volume = 0 } volume1 :: Assertion volume1 = @@ -68,7 +69,8 @@ tetrahedron2_geometry_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values } + fv = empty_values, + precomputed_volume = 0 } volume1 :: Assertion volume1 = assertEqual "volume1 is correct" True (vol ~= (1/3)) @@ -106,7 +108,8 @@ containment_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values } + fv = empty_values, + precomputed_volume = 0 } contained = contains_point t exterior_point @@ -120,7 +123,8 @@ containment_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values } + fv = empty_values, + precomputed_volume = 0 } contained = contains_point t exterior_point @@ -134,7 +138,8 @@ containment_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values } + fv = empty_values, + precomputed_volume = 0 } contained = contains_point t exterior_point @@ -148,7 +153,8 @@ containment_tests = v1 = p1, v2 = p2, v3 = p3, - fv = empty_values } + fv = empty_values, + precomputed_volume = 0 } contained = contains_point t exterior_point -- 2.44.2 From b2e1c440b9b1bb99ae564d6600230bbd1f7d204c Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 2 Sep 2011 11:03:12 -0400 Subject: [PATCH 09/16] Finish the precomputed_volume optimization. --- src/Cube.hs | 56 ++++++++++++++++++++++++---------------------- src/Grid.hs | 5 ++++- src/Tetrahedron.hs | 15 ++++++++----- 3 files changed, 42 insertions(+), 34 deletions(-) diff --git a/src/Cube.hs b/src/Cube.hs index 1e83a3e..ef2d9ce 100644 --- a/src/Cube.hs +++ b/src/Cube.hs @@ -15,7 +15,8 @@ data Cube = Cube { h :: Double, i :: Int, j :: Int, k :: Int, - fv :: FunctionValues } + fv :: FunctionValues, + tetrahedra_volume :: Double } deriving (Eq) @@ -26,7 +27,8 @@ instance Arbitrary Cube where j' <- choose (coordmin, coordmax) k' <- choose (coordmin, coordmax) fv' <- arbitrary :: Gen FunctionValues - return (Cube h' i' j' k' fv') + (Positive tet_vol) <- arbitrary :: Gen (Positive Double) + return (Cube h' i' j' k' fv' tet_vol) where coordmin = -268435456 -- -(2^29 / 2) coordmax = 268435456 -- +(2^29 / 2) @@ -51,7 +53,7 @@ instance Show Cube where -- | Returns an empty 'Cube'. empty_cube :: Cube -empty_cube = Cube 0 0 0 0 empty_values +empty_cube = Cube 0 0 0 0 empty_values 0 -- | The left-side boundary of the cube. See Sorokina and Zeilfelder, @@ -205,7 +207,7 @@ tetrahedron0 c = v1' = center (front_face c) v2' = Face.v0 (front_face c) v3' = Face.v1 (front_face c) - vol = 0 + vol = tetrahedra_volume c tetrahedron1 :: Cube -> Tetrahedron tetrahedron1 c = @@ -216,7 +218,7 @@ tetrahedron1 c = v2' = Face.v1 (front_face c) v3' = Face.v2 (front_face c) fv' = rotate ccwx (Cube.fv c) - vol = 0 + vol = tetrahedra_volume c tetrahedron2 :: Cube -> Tetrahedron tetrahedron2 c = @@ -227,7 +229,7 @@ tetrahedron2 c = v2' = Face.v2 (front_face c) v3' = Face.v3 (front_face c) fv' = rotate ccwx $ rotate ccwx $ Cube.fv c - vol = 0 + vol = tetrahedra_volume c tetrahedron3 :: Cube -> Tetrahedron tetrahedron3 c = @@ -238,7 +240,7 @@ tetrahedron3 c = v2' = Face.v3 (front_face c) v3' = Face.v0 (front_face c) fv' = rotate cwx (Cube.fv c) - vol = 0 + vol = tetrahedra_volume c tetrahedron4 :: Cube -> Tetrahedron tetrahedron4 c = @@ -249,7 +251,7 @@ tetrahedron4 c = v2' = Face.v0 (top_face c) v3' = Face.v1 (top_face c) fv' = rotate cwy (Cube.fv c) - vol = 0 + vol = tetrahedra_volume c tetrahedron5 :: Cube -> Tetrahedron tetrahedron5 c = @@ -260,7 +262,7 @@ tetrahedron5 c = v2' = Face.v1 (top_face c) v3' = Face.v2 (top_face c) fv' = rotate cwy $ rotate cwz $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron6 :: Cube -> Tetrahedron tetrahedron6 c = @@ -273,7 +275,7 @@ tetrahedron6 c = fv' = rotate cwy $ rotate cwz $ rotate cwz $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron7 :: Cube -> Tetrahedron tetrahedron7 c = @@ -284,7 +286,7 @@ tetrahedron7 c = v2' = Face.v3 (top_face c) v3' = Face.v0 (top_face c) fv' = rotate cwy $ rotate ccwz $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron8 :: Cube -> Tetrahedron tetrahedron8 c = @@ -295,7 +297,7 @@ tetrahedron8 c = v2' = Face.v0 (back_face c) v3' = Face.v1 (back_face c) fv' = rotate cwy $ rotate cwy $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron9 :: Cube -> Tetrahedron tetrahedron9 c = @@ -308,7 +310,7 @@ tetrahedron9 c = fv' = rotate cwy $ rotate cwy $ rotate cwx $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron10 :: Cube -> Tetrahedron tetrahedron10 c = @@ -323,7 +325,7 @@ tetrahedron10 c = $ rotate cwx $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron11 :: Cube -> Tetrahedron tetrahedron11 c = @@ -336,7 +338,7 @@ tetrahedron11 c = fv' = rotate cwy $ rotate cwy $ rotate ccwx $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron12 :: Cube -> Tetrahedron @@ -348,7 +350,7 @@ tetrahedron12 c = v2' = Face.v0 (down_face c) v3' = Face.v1 (down_face c) fv' = rotate ccwy (Tetrahedron.fv (tetrahedron0 c)) - vol = 0 + vol = tetrahedra_volume c tetrahedron13 :: Cube -> Tetrahedron @@ -360,7 +362,7 @@ tetrahedron13 c = v2' = Face.v1 (down_face c) v3' = Face.v2 (down_face c) fv' = rotate ccwy $ rotate ccwz $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron14 :: Cube -> Tetrahedron @@ -374,7 +376,7 @@ tetrahedron14 c = fv' = rotate ccwy $ rotate ccwz $ rotate ccwz $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron15 :: Cube -> Tetrahedron @@ -386,7 +388,7 @@ tetrahedron15 c = v2' = Face.v3 (down_face c) v3' = Face.v0 (down_face c) fv' = rotate ccwy $ rotate cwz $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron16 :: Cube -> Tetrahedron @@ -398,7 +400,7 @@ tetrahedron16 c = v2' = Face.v0 (right_face c) v3' = Face.v1 (right_face c) fv' = rotate ccwz (Tetrahedron.fv (tetrahedron0 c)) - vol = 0 + vol = tetrahedra_volume c tetrahedron17 :: Cube -> Tetrahedron @@ -410,7 +412,7 @@ tetrahedron17 c = v2' = Face.v1 (right_face c) v3' = Face.v2 (right_face c) fv' = rotate ccwz $ rotate cwy $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron18 :: Cube -> Tetrahedron @@ -424,7 +426,7 @@ tetrahedron18 c = fv' = rotate ccwz $ rotate cwy $ rotate cwy $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron19 :: Cube -> Tetrahedron @@ -437,7 +439,7 @@ tetrahedron19 c = v3' = Face.v0 (right_face c) fv' = rotate ccwz $ rotate ccwy $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron20 :: Cube -> Tetrahedron @@ -449,7 +451,7 @@ tetrahedron20 c = v2' = Face.v0 (left_face c) v3' = Face.v1 (left_face c) fv' = rotate cwz (Tetrahedron.fv (tetrahedron0 c)) - vol = 0 + vol = tetrahedra_volume c tetrahedron21 :: Cube -> Tetrahedron @@ -461,7 +463,7 @@ tetrahedron21 c = v2' = Face.v1 (left_face c) v3' = Face.v2 (left_face c) fv' = rotate cwz $ rotate ccwy $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron22 :: Cube -> Tetrahedron @@ -475,7 +477,7 @@ tetrahedron22 c = fv' = rotate cwz $ rotate ccwy $ rotate ccwy $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedron23 :: Cube -> Tetrahedron @@ -488,7 +490,7 @@ tetrahedron23 c = v3' = Face.v0 (left_face c) fv' = rotate cwz $ rotate cwy $ Tetrahedron.fv (tetrahedron0 c) - vol = 0 + vol = tetrahedra_volume c tetrahedra :: Cube -> [Tetrahedron] diff --git a/src/Grid.hs b/src/Grid.hs index 7325d2b..d9fa975 100644 --- a/src/Grid.hs +++ b/src/Grid.hs @@ -57,7 +57,10 @@ cubes g | i <- [0..xmax], j <- [0..ymax], k <- [0..zmax], - let cube_ijk = Cube (h g) i j k (make_values fvs i j k)] + let delta = h g, + let tet_vol = (1/24)*(delta^(3::Int)), + let cube_ijk = + Cube delta i j k (make_values fvs i j k) tet_vol] where xmax = xsize - 1 ymax = ysize - 1 diff --git a/src/Tetrahedron.hs b/src/Tetrahedron.hs index eef1656..1f7c22b 100644 --- a/src/Tetrahedron.hs +++ b/src/Tetrahedron.hs @@ -29,8 +29,11 @@ instance Arbitrary Tetrahedron where rnd_v2 <- arbitrary :: Gen Point rnd_v3 <- arbitrary :: Gen Point rnd_fv <- arbitrary :: Gen FunctionValues - rnd_vol <- arbitrary :: Gen Double - return (Tetrahedron rnd_fv rnd_v0 rnd_v1 rnd_v2 rnd_v3 rnd_vol) + -- We can't assign an incorrect precomputed volume, + -- so we have to calculate the correct one here. + let t' = Tetrahedron rnd_fv rnd_v0 rnd_v1 rnd_v2 rnd_v3 0 + let vol = volume t' + return (Tetrahedron rnd_fv rnd_v0 rnd_v1 rnd_v2 rnd_v3 vol) instance Show Tetrahedron where @@ -267,27 +270,27 @@ volume t -- | The barycentric coordinates of a point with respect to v0. b0 :: Tetrahedron -> (RealFunction Point) -b0 t point = (volume inner_tetrahedron) / (volume t) +b0 t point = (volume inner_tetrahedron) / (precomputed_volume t) where inner_tetrahedron = t { v0 = point } -- | The barycentric coordinates of a point with respect to v1. b1 :: Tetrahedron -> (RealFunction Point) -b1 t point = (volume inner_tetrahedron) / (volume t) +b1 t point = (volume inner_tetrahedron) / (precomputed_volume t) where inner_tetrahedron = t { v1 = point } -- | The barycentric coordinates of a point with respect to v2. b2 :: Tetrahedron -> (RealFunction Point) -b2 t point = (volume inner_tetrahedron) / (volume t) +b2 t point = (volume inner_tetrahedron) / (precomputed_volume t) where inner_tetrahedron = t { v2 = point } -- | The barycentric coordinates of a point with respect to v3. b3 :: Tetrahedron -> (RealFunction Point) -b3 t point = (volume inner_tetrahedron) / (volume t) +b3 t point = (volume inner_tetrahedron) / (precomputed_volume t) where inner_tetrahedron = t { v3 = point } -- 2.44.2 From 763af71ab386625469069de1cbbbf52a18f526fe Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 2 Sep 2011 12:41:17 -0400 Subject: [PATCH 10/16] Fix (I think) the cube offset issue. --- src/Grid.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Grid.hs b/src/Grid.hs index d9fa975..d87114f 100644 --- a/src/Grid.hs +++ b/src/Grid.hs @@ -98,8 +98,8 @@ calculate_containing_cube_coordinate g coord -- Don't use a cube on the boundary if we can help it. This -- returns cube #1 if we would have returned cube #0 and cube #1 -- exists. - | coord == offset && (xsize > 0 && ysize > 0 && zsize > 0) = 1 | coord < offset = 0 + | coord == offset && (xsize > 1 && ysize > 1 && zsize > 1) = 1 | otherwise = (ceiling ( (coord + offset) / cube_width )) - 1 where (xsize, ysize, zsize) = dims (function_values g) @@ -130,9 +130,10 @@ zoom_result :: Grid -> ScaleFactor -> R.DIM3 -> Double zoom_result g (sfx, sfy, sfz) (R.Z R.:. i R.:. j R.:. k) = f p where - i' = (fromIntegral i) / (fromIntegral sfx) - j' = (fromIntegral j) / (fromIntegral sfy) - k' = (fromIntegral k) / (fromIntegral sfz) + offset = (h g)/2 + i' = (fromIntegral i) / (fromIntegral sfx) - offset + j' = (fromIntegral j) / (fromIntegral sfy) - offset + k' = (fromIntegral k) / (fromIntegral sfz) - offset p = (i', j', k') :: Point c = find_containing_cube g p t = find_containing_tetrahedron c p -- 2.44.2 From b18e13462e37fd48e1d19d131a41e3743252ae31 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 2 Sep 2011 12:58:40 -0400 Subject: [PATCH 11/16] Only compute 'cubes' once, and store it in a new Grid field, cube_grid. --- src/Grid.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/Grid.hs b/src/Grid.hs index d87114f..ba8ca20 100644 --- a/src/Grid.hs +++ b/src/Grid.hs @@ -24,7 +24,8 @@ type CubeGrid = Array (Int,Int,Int) Cube -- function at the grid points, which are distance h from one -- another in each direction (x,y,z). data Grid = Grid { h :: Double, -- MUST BE GREATER THAN ZERO! - function_values :: Values3D } + function_values :: Values3D, + cube_grid :: CubeGrid } deriving (Eq, Show) @@ -40,24 +41,23 @@ instance Arbitrary Grid where make_grid :: Double -> Values3D -> Grid make_grid grid_size values | grid_size <= 0 = error "grid size must be positive" - | otherwise = Grid grid_size values + | otherwise = Grid grid_size values (cubes grid_size values) -- | Creates an empty grid with grid size 1. empty_grid :: Grid -empty_grid = Grid 1 empty3d +empty_grid = make_grid 1 empty3d -- | Returns a three-dimensional array of cubes centered on the grid --- points of g with the appropriate 'FunctionValues'. -cubes :: Grid -> CubeGrid -cubes g +-- points (h*i, h*j, h*k) with the appropriate 'FunctionValues'. +cubes :: Double -> Values3D -> CubeGrid +cubes delta fvs = array (lbounds, ubounds) [ ((i,j,k), cube_ijk) | i <- [0..xmax], j <- [0..ymax], k <- [0..zmax], - let delta = h g, let tet_vol = (1/24)*(delta^(3::Int)), let cube_ijk = Cube delta i j k (make_values fvs i j k) tet_vol] @@ -67,7 +67,6 @@ cubes g zmax = zsize - 1 lbounds = (0, 0, 0) ubounds = (xmax, ymax, zmax) - fvs = function_values g (xsize, ysize, zsize) = dims fvs @@ -82,7 +81,7 @@ cube_at g i j k | j >= ysize = error "j >= ysize in cube_at" | k < 0 = error "k < 0 in cube_at" | k >= zsize = error "k >= zsize in cube_at" - | otherwise = (cubes g) ! (i,j,k) + | otherwise = (cube_grid g) ! (i,j,k) where fvs = function_values g (xsize, ysize, zsize) = dims fvs -- 2.44.2 From dd58892d526586bc436b88d18a54b954be032761 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Sat, 3 Sep 2011 10:56:03 -0400 Subject: [PATCH 12/16] Add some C optimizations. Minor makefile cleanup. --- makefile | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/makefile b/makefile index 6820e5a..74b7b95 100644 --- a/makefile +++ b/makefile @@ -1,3 +1,6 @@ +BIN := spline3 +TMPDIR := /tmp + GHC_WARNINGS := -Wall GHC_WARNINGS += -fwarn-hi-shadowing GHC_WARNINGS += -fwarn-missing-signatures @@ -9,30 +12,34 @@ GHC_WARNINGS += -fwarn-incomplete-record-updates GHC_WARNINGS += -fwarn-monomorphism-restriction GHC_WARNINGS += -fwarn-unused-do-bind -BIN := spline3 -TMPDIR := /tmp -GHC_OPTS := $(GHC_WARNINGS) \ +OPTIMIZATIONS := -O2 +OPTIMIZATIONS += -fexcess-precision +OPTIMIZATIONS += -fno-spec-constr-count +OPTIMIZATIONS += -optc-O2 +OPTIMIZATIONS += -optc-march=native + +GHC_OPTS := $(OPTIMIZATIONS) \ + $(GHC_WARNINGS) \ -odir $(TMPDIR) \ -hidir $(TMPDIR) \ --make \ -rtsopts \ -threaded \ - -fno-spec-constr-count \ -o bin/${BIN} .PHONY : test publish_doc doc src_html hlint $(BIN): src/*.hs - ghc -O2 $(GHC_OPTS) src/*.hs + ghc $(GHC_OPTS) src/*.hs all: $(BIN) test_src test_src: src/Tests/*.hs - ghc -O2 $(GHC_OPTS) src/*.hs src/Tests/*.hs + ghc $(GHC_OPTS) src/*.hs src/Tests/*.hs profile: src/*.hs - ghc -O2 $(GHC_OPTS) -prof -auto-all src/*.hs + ghc $(GHC_OPTS) -prof -auto-all src/*.hs clean: rm -f bin/$(BIN) -- 2.44.2 From 1f20ae355d28b53fc2e1e31c4bd131e9ede00a87 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Sat, 3 Sep 2011 16:54:53 -0400 Subject: [PATCH 13/16] Move the FunctionValues tests into the FunctionValues module. --- src/FunctionValues.hs | 60 +++++++++++++++++++++++++++++++++++-- src/Tests/Cube.hs | 49 +++++++++++++++++------------- src/Tests/FunctionValues.hs | 41 ------------------------- src/Tests/Tetrahedron.hs | 1 - test/TestSuite.hs | 5 +--- 5 files changed, 88 insertions(+), 68 deletions(-) delete mode 100644 src/Tests/FunctionValues.hs diff --git a/src/FunctionValues.hs b/src/FunctionValues.hs index 895f925..00bb0a8 100644 --- a/src/FunctionValues.hs +++ b/src/FunctionValues.hs @@ -1,12 +1,25 @@ -- | The FunctionValues module contains the 'FunctionValues' type and -- the functions used to manipulate it. -module FunctionValues +module FunctionValues ( + FunctionValues, + empty_values, + eval, + make_values, + rotate, + function_values_tests, + value_at + ) where import Prelude hiding (LT) +import Test.HUnit +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) import Test.QuickCheck (Arbitrary(..), choose) -import Cardinal +import Assertions (assertTrue) +import Cardinal ( Cardinal(..) ) +import Examples (trilinear) import Values (Values3D, dims, idx) -- | The FunctionValues type represents the value of our function f at @@ -258,3 +271,46 @@ rotate rotation fv = back_right_down = eval fv (rotation BRD), back_right_top = eval fv (rotation BRT), interior = interior fv } + + + +-- | Ensure that the trilinear values wind up where we think they +-- should. +test_directions :: Assertion +test_directions = + assertTrue "all direction functions work" (and equalities) + where + fvs = make_values trilinear 1 1 1 + equalities = [ interior fvs == 4, + front fvs == 1, + back fvs == 7, + left fvs == 2, + right fvs == 6, + down fvs == 3, + top fvs == 5, + front_left fvs == 1, + front_right fvs == 1, + front_down fvs == 1, + front_top fvs == 1, + back_left fvs == 3, + back_right fvs == 11, + back_down fvs == 5, + back_top fvs == 9, + left_down fvs == 2, + left_top fvs == 2, + right_down fvs == 4, + right_top fvs == 8, + front_left_down fvs == 1, + front_left_top fvs == 1, + front_right_down fvs == 1, + front_right_top fvs == 1, + back_left_down fvs == 3, + back_left_top fvs == 3, + back_right_down fvs == 7, + back_right_top fvs == 15] + + +function_values_tests :: Test.Framework.Test +function_values_tests = + testGroup "FunctionValues Tests" + [ testCase "test directions" test_directions ] diff --git a/src/Tests/Cube.hs b/src/Tests/Cube.hs index 0a1cc50..17ea7f8 100644 --- a/src/Tests/Cube.hs +++ b/src/Tests/Cube.hs @@ -8,7 +8,6 @@ import Comparisons import Cube hiding (i, j, k) import FunctionValues import Misc (all_equal, disjoint) -import Tests.FunctionValues () import Tetrahedron (b0, b1, b2, b3, c, fv, v0, v1, v2, v3, volume) @@ -412,25 +411,35 @@ prop_c_tilde_2100_correct cube = t0 = tetrahedron0 cube t6 = tetrahedron6 cube fvs = Tetrahedron.fv t0 - int = interior fvs - f = front fvs - r = right fvs - l = left fvs - b = back fvs - ft = front_top fvs - rt = right_top fvs - lt = left_top fvs - bt = back_top fvs - t = top fvs - d = down fvs - fr = front_right fvs - fl = front_left fvs - br = back_right fvs - bl = back_left fvs - fd = front_down fvs - rd = right_down fvs - ld = left_down fvs - bd = back_down fvs + (Cube _ i j k _ _) = cube + f = value_at fvs (i-1) j k + b = value_at fvs (i+1) j k + l = value_at fvs i (j-1) k + r = value_at fvs i (j+1) k + d = value_at fvs i j (k-1) + t = value_at fvs i j (k+1) + fl = value_at fvs (i-1) (j-1) k + fr = value_at fvs (i-1) (j+1) k + fd = value_at fvs (i-1) j (k-1) + ft = value_at fvs (i-1) j (k+1) + bl = value_at fvs (i+1) (j-1) k + br = value_at fvs (i+1) (j+1) k + bd = value_at fvs (i+1) j (k-1) + bt = value_at fvs (i+1) j (k+1) + ld = value_at fvs i (j-1) (k-1) + lt = value_at fvs i (j-1) (k+1) + rd = value_at fvs i (j+1) (k-1) + rt = value_at fvs i (j+1) (k+1) + fld = value_at fvs (i-1) (j-1) (k-1) + flt = value_at fvs (i-1) (j-1) (k+1) + frd = value_at fvs (i-1) (j+1) (k-1) + frt = value_at fvs (i-1) (j+1) (k+1) + bld = value_at fvs (i+1) (j-1) (k-1) + blt = value_at fvs (i+1) (j-1) (k+1) + brd = value_at fvs (i+1) (j+1) (k-1) + brt = value_at fvs (i+1) (j+1) (k+1) + int = value_at fvs i j k + -- Tests to check that the correct edges are incidental. prop_t0_shares_edge_with_t1 :: Cube -> Bool diff --git a/src/Tests/FunctionValues.hs b/src/Tests/FunctionValues.hs deleted file mode 100644 index 9cada35..0000000 --- a/src/Tests/FunctionValues.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Tests.FunctionValues -where - -import Test.HUnit - -import Assertions -import Examples -import FunctionValues - -test_directions :: Assertion -test_directions = - assertTrue "all direction functions work" (and equalities) - where - fvs = make_values trilinear 1 1 1 - equalities = [ interior fvs == 4, - front fvs == 1, - back fvs == 7, - left fvs == 2, - right fvs == 6, - down fvs == 3, - top fvs == 5, - front_left fvs == 1, - front_right fvs == 1, - front_down fvs == 1, - front_top fvs == 1, - back_left fvs == 3, - back_right fvs == 11, - back_down fvs == 5, - back_top fvs == 9, - left_down fvs == 2, - left_top fvs == 2, - right_down fvs == 4, - right_top fvs == 8, - front_left_down fvs == 1, - front_left_top fvs == 1, - front_right_down fvs == 1, - front_right_top fvs == 1, - back_left_down fvs == 3, - back_left_top fvs == 3, - back_right_down fvs == 7, - back_right_top fvs == 15] diff --git a/src/Tests/Tetrahedron.hs b/src/Tests/Tetrahedron.hs index 3b511d2..ec71e3b 100644 --- a/src/Tests/Tetrahedron.hs +++ b/src/Tests/Tetrahedron.hs @@ -9,7 +9,6 @@ import Test.QuickCheck (Property, (==>)) import Cardinal import Comparisons import FunctionValues -import Tests.FunctionValues() import Tetrahedron import ThreeDimensional diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 66f592b..73723c2 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -9,9 +9,9 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit import Test.QuickCheck (Testable ()) +import FunctionValues (functionvalues_tests) import Tests.Cardinal import Tests.Cube as TC -import Tests.FunctionValues import Tests.Grid import Tests.Misc import Tests.Tetrahedron as TT @@ -30,9 +30,6 @@ cardinal_tests = testGroup "Cardinal Tests" [ tc "c-tilde_2100 rotation correct" test_c_tilde_2100_rotation_correct ] -function_values_tests :: Test.Framework.Test -function_values_tests = - testGroup "FunctionValues Tests" [ tc "test directions" test_directions ] grid_tests :: Test.Framework.Test grid_tests = -- 2.44.2 From c3d4eba6aa5ada928b351e9ec7c12c3077808ba7 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Sat, 3 Sep 2011 16:55:40 -0400 Subject: [PATCH 14/16] Default to compiling with llvm. Add a 'gcc' makefile target. --- makefile | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/makefile b/makefile index 74b7b95..c230b4b 100644 --- a/makefile +++ b/makefile @@ -15,8 +15,6 @@ GHC_WARNINGS += -fwarn-unused-do-bind OPTIMIZATIONS := -O2 OPTIMIZATIONS += -fexcess-precision OPTIMIZATIONS += -fno-spec-constr-count -OPTIMIZATIONS += -optc-O2 -OPTIMIZATIONS += -optc-march=native GHC_OPTS := $(OPTIMIZATIONS) \ $(GHC_WARNINGS) \ @@ -31,7 +29,10 @@ GHC_OPTS := $(OPTIMIZATIONS) \ .PHONY : test publish_doc doc src_html hlint $(BIN): src/*.hs - ghc $(GHC_OPTS) src/*.hs + ghc -fllvm $(GHC_OPTS) src/*.hs + +gcc: src/*.hs + ghc -optc-O2 -optc-march=native $(GHC_OPTS) src/*.hs all: $(BIN) test_src -- 2.44.2 From 9849853e69c46b46996e8c775d15661b2aba27a8 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Sat, 3 Sep 2011 18:40:14 -0400 Subject: [PATCH 15/16] A bunch more test cleanup. --- src/FunctionValues.hs | 69 +++++++++++++++++++++++++++++++++++++++- src/Misc.hs | 32 +++++++++++++++++++ src/Tests/Cube.hs | 50 +++++++++-------------------- src/Tests/Misc.hs | 20 ------------ src/Tests/Tetrahedron.hs | 56 -------------------------------- test/TestSuite.hs | 21 ++---------- 6 files changed, 118 insertions(+), 130 deletions(-) delete mode 100644 src/Tests/Misc.hs diff --git a/src/FunctionValues.hs b/src/FunctionValues.hs index 00bb0a8..e9da25f 100644 --- a/src/FunctionValues.hs +++ b/src/FunctionValues.hs @@ -7,6 +7,7 @@ module FunctionValues ( make_values, rotate, function_values_tests, + function_values_properties, value_at ) where @@ -15,10 +16,11 @@ import Prelude hiding (LT) import Test.HUnit import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck (Arbitrary(..), choose) import Assertions (assertTrue) -import Cardinal ( Cardinal(..) ) +import Cardinal ( Cardinal(..), cwx, cwy, cwz ) import Examples (trilinear) import Values (Values3D, dims, idx) @@ -314,3 +316,68 @@ function_values_tests :: Test.Framework.Test function_values_tests = testGroup "FunctionValues Tests" [ testCase "test directions" test_directions ] + + +prop_x_rotation_doesnt_affect_front :: FunctionValues -> Bool +prop_x_rotation_doesnt_affect_front fv0 = + expr1 == expr2 + where + fv1 = rotate cwx fv0 + expr1 = front fv0 + expr2 = front fv1 + +prop_x_rotation_doesnt_affect_back :: FunctionValues -> Bool +prop_x_rotation_doesnt_affect_back fv0 = + expr1 == expr2 + where + fv1 = rotate cwx fv0 + expr1 = back fv0 + expr2 = back fv1 + + +prop_y_rotation_doesnt_affect_left :: FunctionValues -> Bool +prop_y_rotation_doesnt_affect_left fv0 = + expr1 == expr2 + where + fv1 = rotate cwy fv0 + expr1 = left fv0 + expr2 = left fv1 + +prop_y_rotation_doesnt_affect_right :: FunctionValues -> Bool +prop_y_rotation_doesnt_affect_right fv0 = + expr1 == expr2 + where + fv1 = rotate cwy fv0 + expr1 = right fv0 + expr2 = right fv1 + + +prop_z_rotation_doesnt_affect_down :: FunctionValues -> Bool +prop_z_rotation_doesnt_affect_down fv0 = + expr1 == expr2 + where + fv1 = rotate cwz fv0 + expr1 = down fv0 + expr2 = down fv1 + + +prop_z_rotation_doesnt_affect_top :: FunctionValues -> Bool +prop_z_rotation_doesnt_affect_top fv0 = + expr1 == expr2 + where + fv1 = rotate cwz fv0 + expr1 = top fv0 + expr2 = top fv1 + + +function_values_properties :: Test.Framework.Test +function_values_properties = + let tp = testProperty + in + testGroup "FunctionValues Properties" [ + tp "x rotation doesn't affect front" prop_x_rotation_doesnt_affect_front, + tp "x rotation doesn't affect back" prop_x_rotation_doesnt_affect_back, + tp "y rotation doesn't affect left" prop_y_rotation_doesnt_affect_left, + tp "y rotation doesn't affect right" prop_y_rotation_doesnt_affect_right, + tp "z rotation doesn't affect top" prop_z_rotation_doesnt_affect_top, + tp "z rotation doesn't affect down" prop_z_rotation_doesnt_affect_down ] diff --git a/src/Misc.hs b/src/Misc.hs index b9220cb..16b0ead 100644 --- a/src/Misc.hs +++ b/src/Misc.hs @@ -4,6 +4,11 @@ module Misc where import Data.List (intersect) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit +import Test.QuickCheck -- | The standard factorial function. See @@ -75,3 +80,30 @@ all_equal xs = disjoint :: (Eq a) => [a] -> [a] -> Bool disjoint xs ys = intersect xs ys == [] + + + +prop_factorial_greater :: Int -> Property +prop_factorial_greater n = + n <= 20 ==> factorial n >= n + + +test_flatten1 :: Assertion +test_flatten1 = + assertEqual "flatten actually works" expected_list actual_list + where + target = [[[1::Int]], [[2, 3]]] + expected_list = [1, 2, 3] + actual_list = flatten target + + +misc_tests :: Test.Framework.Test +misc_tests = + testGroup "Misc Tests" [ + testCase "flatten (1)" test_flatten1 ] + + +misc_properties :: Test.Framework.Test +misc_properties = + testGroup "Misc Properties" [ + testProperty "factorial greater" prop_factorial_greater ] diff --git a/src/Tests/Cube.hs b/src/Tests/Cube.hs index 17ea7f8..e9e21d6 100644 --- a/src/Tests/Cube.hs +++ b/src/Tests/Cube.hs @@ -398,47 +398,27 @@ prop_c_tilde_2100_rotation_correct cube = (1/192)*(FD + RD + LD + BD) --- | We know what (c t6 2 1 0 0) should be from Sorokina and Zeilfelder, p. 87. --- This test checks the actual value based on the FunctionValues of the cube. +-- | We know what (c t6 2 1 0 0) should be from Sorokina and +-- Zeilfelder, p. 87. This test checks the actual value based on +-- the FunctionValues of the cube. +-- +-- If 'prop_c_tilde_2100_rotation_correct' passes, then this test is +-- even meaningful! prop_c_tilde_2100_correct :: Cube -> Bool prop_c_tilde_2100_correct cube = - c t6 2 1 0 0 == (3/8)*int - + (1/12)*(f + r + l + b) - + (1/64)*(ft + rt + lt + bt) - + (7/48)*t + (1/48)*d + (1/96)*(fr + fl + br + bl) - + (1/192)*(fd + rd + ld + bd) + c t6 2 1 0 0 == expected where t0 = tetrahedron0 cube t6 = tetrahedron6 cube fvs = Tetrahedron.fv t0 - (Cube _ i j k _ _) = cube - f = value_at fvs (i-1) j k - b = value_at fvs (i+1) j k - l = value_at fvs i (j-1) k - r = value_at fvs i (j+1) k - d = value_at fvs i j (k-1) - t = value_at fvs i j (k+1) - fl = value_at fvs (i-1) (j-1) k - fr = value_at fvs (i-1) (j+1) k - fd = value_at fvs (i-1) j (k-1) - ft = value_at fvs (i-1) j (k+1) - bl = value_at fvs (i+1) (j-1) k - br = value_at fvs (i+1) (j+1) k - bd = value_at fvs (i+1) j (k-1) - bt = value_at fvs (i+1) j (k+1) - ld = value_at fvs i (j-1) (k-1) - lt = value_at fvs i (j-1) (k+1) - rd = value_at fvs i (j+1) (k-1) - rt = value_at fvs i (j+1) (k+1) - fld = value_at fvs (i-1) (j-1) (k-1) - flt = value_at fvs (i-1) (j-1) (k+1) - frd = value_at fvs (i-1) (j+1) (k-1) - frt = value_at fvs (i-1) (j+1) (k+1) - bld = value_at fvs (i+1) (j-1) (k-1) - blt = value_at fvs (i+1) (j-1) (k+1) - brd = value_at fvs (i+1) (j+1) (k-1) - brt = value_at fvs (i+1) (j+1) (k+1) - int = value_at fvs i j k + expected = eval fvs $ + (3/8)*I + + (1/12)*(F + R + L + B) + + (1/64)*(FT + RT + LT + BT) + + (7/48)*T + + (1/48)*D + + (1/96)*(FR + FL + BR + BL) + + (1/192)*(FD + RD + LD + BD) -- Tests to check that the correct edges are incidental. diff --git a/src/Tests/Misc.hs b/src/Tests/Misc.hs deleted file mode 100644 index fd16064..0000000 --- a/src/Tests/Misc.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Tests.Misc -where - -import Test.HUnit -import Test.QuickCheck - -import Misc - -prop_factorial_greater :: Int -> Property -prop_factorial_greater n = - n <= 20 ==> factorial n >= n - - -test_flatten1 :: Assertion -test_flatten1 = - assertEqual "flatten actually works" expected_list actual_list - where - target = [[[1::Int]], [[2, 3]]] - expected_list = [1, 2, 3] - actual_list = flatten target diff --git a/src/Tests/Tetrahedron.hs b/src/Tests/Tetrahedron.hs index ec71e3b..0d92452 100644 --- a/src/Tests/Tetrahedron.hs +++ b/src/Tests/Tetrahedron.hs @@ -286,62 +286,6 @@ prop_c1110_identity t = term3 = (3/4)*((p t 2 1 0 0) + (p t 1 2 0 0) + (p t 2 0 1 0)) term4 = (3/4)*((p t 1 0 2 0) + (p t 0 2 1 0) + (p t 0 1 2 0)) -prop_x_rotation_doesnt_affect_front :: Tetrahedron -> Bool -prop_x_rotation_doesnt_affect_front t = - expr1 == expr2 - where - fv0 = Tetrahedron.fv t - fv1 = rotate cwx (Tetrahedron.fv t) - expr1 = front fv0 - expr2 = front fv1 - -prop_x_rotation_doesnt_affect_back :: Tetrahedron -> Bool -prop_x_rotation_doesnt_affect_back t = - expr1 == expr2 - where - fv0 = Tetrahedron.fv t - fv1 = rotate cwx (Tetrahedron.fv t) - expr1 = back fv0 - expr2 = back fv1 - - -prop_y_rotation_doesnt_affect_left :: Tetrahedron -> Bool -prop_y_rotation_doesnt_affect_left t = - expr1 == expr2 - where - fv0 = Tetrahedron.fv t - fv1 = rotate cwy (Tetrahedron.fv t) - expr1 = left fv0 - expr2 = left fv1 - -prop_y_rotation_doesnt_affect_right :: Tetrahedron -> Bool -prop_y_rotation_doesnt_affect_right t = - expr1 == expr2 - where - fv0 = Tetrahedron.fv t - fv1 = rotate cwy (Tetrahedron.fv t) - expr1 = right fv0 - expr2 = right fv1 - - -prop_z_rotation_doesnt_affect_down :: Tetrahedron -> Bool -prop_z_rotation_doesnt_affect_down t = - expr1 == expr2 - where - fv0 = Tetrahedron.fv t - fv1 = rotate cwz (Tetrahedron.fv t) - expr1 = down fv0 - expr2 = down fv1 - - -prop_z_rotation_doesnt_affect_top :: Tetrahedron -> Bool -prop_z_rotation_doesnt_affect_top t = - expr1 == expr2 - where - fv0 = Tetrahedron.fv t - fv1 = rotate cwz (Tetrahedron.fv t) - expr1 = top fv0 - expr2 = top fv1 prop_swapping_vertices_doesnt_affect_coefficients1 :: Tetrahedron -> Bool prop_swapping_vertices_doesnt_affect_coefficients1 t = diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 73723c2..a3563b0 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -9,11 +9,11 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit import Test.QuickCheck (Testable ()) -import FunctionValues (functionvalues_tests) +import FunctionValues (function_values_tests, function_values_properties) +import Misc (misc_tests, misc_properties) import Tests.Cardinal import Tests.Cube as TC import Tests.Grid -import Tests.Misc import Tests.Tetrahedron as TT main :: IO () @@ -41,11 +41,6 @@ grid_tests = tc "zeros reproduced" test_zeros_reproduced ] -misc_tests :: Test.Framework.Test -misc_tests = - testGroup "Misc Tests" [ - tc "flatten (1)" test_flatten1 ] - tetrahedron_tests :: Test.Framework.Test tetrahedron_tests = testGroup "Tetrahedron Tests" [ @@ -57,10 +52,6 @@ tetrahedron_tests = tp :: Test.QuickCheck.Testable a => Test.Framework.TestName -> a -> Test.Framework.Test tp = testProperty -misc_properties :: Test.Framework.Test -misc_properties = - testGroup "Misc Properties" [ - tp "factorial greater" prop_factorial_greater ] cardinal_properties :: Test.Framework.Test cardinal_properties = @@ -195,13 +186,7 @@ tetrahedron_properties = tp "swapping_vertices_doesnt_affect_coefficients3" $ prop_swapping_vertices_doesnt_affect_coefficients3, tp "swapping_vertices_doesnt_affect_coefficients4" - $ prop_swapping_vertices_doesnt_affect_coefficients4, - tp "x rotation doesn't affect front" prop_x_rotation_doesnt_affect_front, - tp "x rotation doesn't affect back" prop_x_rotation_doesnt_affect_back, - tp "y rotation doesn't affect left" prop_y_rotation_doesnt_affect_left, - tp "y rotation doesn't affect right" prop_y_rotation_doesnt_affect_right, - tp "z rotation doesn't affect top" prop_z_rotation_doesnt_affect_top, - tp "z rotation doesn't affect down" prop_z_rotation_doesnt_affect_down ] + $ prop_swapping_vertices_doesnt_affect_coefficients4 ] -- Do the slow tests last so we can stop paying attention. -- 2.44.2 From 957754c693525096c5fd7427decd6404bbb03379 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Sat, 3 Sep 2011 19:49:37 -0400 Subject: [PATCH 16/16] Move the Cardinal tests into the Cardinal module. --- src/Cardinal.hs | 233 +++++++++++++++++++++++++++++++++++++++++- src/Tests/Cardinal.hs | 192 ---------------------------------- test/TestSuite.hs | 29 +----- 3 files changed, 233 insertions(+), 221 deletions(-) delete mode 100644 src/Tests/Cardinal.hs diff --git a/src/Cardinal.hs b/src/Cardinal.hs index 3bff38f..ff410a8 100644 --- a/src/Cardinal.hs +++ b/src/Cardinal.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} + +-- +-- Disable the MR so that let tp = testProperty does what it should! +-- + -- | The Cardinal module contains the Cardinal data type, representing -- a cardinal direction (one of the 26 directions surrounding the -- center of a cube. In addition to those 26 directions, we also @@ -8,7 +14,14 @@ where import Control.Monad (liftM, liftM2) import Prelude hiding (LT) -import Test.QuickCheck (Arbitrary(..), oneof) + +import Test.HUnit +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Test.QuickCheck (Arbitrary(..), Property, (==>), oneof) + data Cardinal = F -- ^ Front | B -- ^ Back @@ -228,3 +241,221 @@ ccwz (Quotient c0 c1) = Quotient (ccwz c0) (ccwz c1) -- | Rotate a cardinal direction clockwise about the z-axis. cwz :: Cardinal -> Cardinal cwz = ccwz . ccwz . ccwz + + + + +-- | We know what (c t6 2 1 0 0) should be from Sorokina and +-- Zeilfelder, p. 87. This test checks that the directions are +-- rotated properly. The order of the letters has to be just right +-- since I haven't defined a proper Eq instance for Cardinals. +test_c_tilde_2100_rotation_correct :: Assertion +test_c_tilde_2100_rotation_correct = + assertEqual "auto-rotate equals manual rotate" ((ccwz . ccwz . cwy) expr1) expr2 + where + expr1 = + (3/8)*I + + (1/12)*(T + R + L + D) + + (1/64)*(FT + FR + FL + FD) + + (7/48)*F + + (1/48)*B + + (1/96)*(RT + LD + LT + RD) + + (1/192)*(BT + BR + BL + BD) + + expr2 = + (3/8)*I + + (1/12)*(F + L + R + B) + + (1/64)*(FT + LT + RT + BT) + + (7/48)*T + + (1/48)*D + + (1/96)*(FL + BR + FR + BL) + + (1/192)*(FD + LD + RD + BD) + +-- | A list of all directions, sans the interior and composite types. +all_directions :: [Cardinal] +all_directions = [L, R, F, B, D, T, FL, FR, FD, FT, + BL, BR, BD, BT, LD, LT, RD, RT, FLD, + FLT, FRD, FRT, BLD, BLT, BRD, BRT] + + +-- | If we rotate a direction (other than front or back) +-- counter-clockwise with respect to the x-axis, we should get a new +-- direction. +prop_ccwx_rotation_changes_direction :: Cardinal -> Property +prop_ccwx_rotation_changes_direction c = + c `elem` [L, R, D, T, FL, FR, FD, FT, BL, BR, BD, BT, LD, LT, + RD, RT, FLD, FLT, FRD, FRT, BLD, BLT, BRD, BRT] + ==> ccwx c /= c + +-- | If we rotate a direction (other than front or back) clockwise +-- with respect to the x-axis, we should get a new direction. +prop_cwx_rotation_changes_direction :: Cardinal -> Property +prop_cwx_rotation_changes_direction c = + -- The front and back faces are unchanged by x-rotation. + c `elem` [L, R, D, T, FL, FR, FD, FT, BL, BR, BD, BT, LD, LT, + RD, RT, FLD, FLT, FRD, FRT, BLD, BLT, BRD, BRT] + ==> cwx c /= c + +-- | If we rotate a direction (other than left or right) +-- counter-clockwise with respect to the y-axis, we should get a new +-- direction. +prop_ccwy_rotation_changes_direction :: Cardinal -> Property +prop_ccwy_rotation_changes_direction c = + c `elem` [F, B, D, T, FL, FR, FD, FT, BL, BR, BD, BT, LD, LT, + RD, RT, FLD, FLT, FRD, FRT, BLD, BLT, BRD, BRT] + ==> ccwy c /= c + + +-- | If we rotate a direction (other than left or right) clockwise +-- with respect to the y-axis, we should get a new direction. +prop_cwy_rotation_changes_direction :: Cardinal -> Property +prop_cwy_rotation_changes_direction c = + c `elem` [F, B, D, T, FL, FR, FD, FT, BL, BR, BD, BT, LD, LT, + RD, RT, FLD, FLT, FRD, FRT, BLD, BLT, BRD, BRT] + ==> cwy c /= c + + +-- | If we rotate a direction (other than top or down) +-- counter-clockwise with respect to the z-axis, we should get a new +-- direction. +prop_ccwz_rotation_changes_direction :: Cardinal -> Property +prop_ccwz_rotation_changes_direction c = + c `elem` [L, R, F, B, FL, FR, FD, FT, BL, BR, BD, BT, LD, LT, + RD, RT, FLD, FLT, FRD, FRT, BLD, BLT, BRD, BRT] + ==> ccwz c /= c + + +-- | If we rotate a direction (other than top or down) clockwise with +-- respect to the z-axis, we should get a new direction. +prop_cwz_rotation_changes_direction :: Cardinal -> Property +prop_cwz_rotation_changes_direction c = + c `elem` [L, R, F, B, FL, FR, FD, FT, BL, BR, BD, BT, LD, LT, + RD, RT, FLD, FLT, FRD, FRT, BLD, BLT, BRD, BRT] + ==> cwz c /= c + + +-- | If we are given a direction c, there should only be one direction +-- d which, when rotated counter-clockwise with respect to the +-- x-axis, produces c. +prop_ccwx_rotation_result_unique :: Cardinal -> Property +prop_ccwx_rotation_result_unique c = + c `elem` all_directions ==> + (length [ d | d <- all_directions, ccwx d == c ]) == 1 + +-- | If we are given a direction c, there should only be one direction +-- d which, when rotated clockwise with respect to the x-axis, +-- produces c. +prop_cwx_rotation_result_unique :: Cardinal -> Property +prop_cwx_rotation_result_unique c = + c `elem` all_directions ==> + (length [ d | d <- all_directions, cwx d == c ]) == 1 + + +-- | If we are given a direction c, there should only be one direction +-- d which, when rotated counter-clockwise with respect to the +-- y-axis, produces c. +prop_ccwy_rotation_result_unique :: Cardinal -> Property +prop_ccwy_rotation_result_unique c = + c `elem` all_directions ==> + (length [ d | d <- all_directions, ccwy d == c ]) == 1 + + +-- | If we are given a direction c, there should only be one direction +-- d which, when rotated clockwise with respect to the y-axis, +-- produces c. +prop_cwy_rotation_result_unique :: Cardinal -> Property +prop_cwy_rotation_result_unique c = + c `elem` all_directions ==> + (length [ d | d <- all_directions, cwy d == c ]) == 1 + + +-- | If we are given a direction c, there should only be one direction +-- d which, when rotated counter-clockwise with respect to the +-- z-axis, produces c. +prop_ccwz_rotation_result_unique :: Cardinal -> Property +prop_ccwz_rotation_result_unique c = + c `elem` all_directions ==> + (length [ d | d <- all_directions, ccwz d == c ]) == 1 + + +-- | If we are given a direction c, there should only be one direction +-- d which, when rotated clockwise with respect to the z-axis, +-- produces c. +prop_cwz_rotation_result_unique :: Cardinal -> Property +prop_cwz_rotation_result_unique c = + c `elem` all_directions ==> + (length [ d | d <- all_directions, cwz d == c ]) == 1 + + +-- | If you rotate a cardinal direction four times in the clockwise +-- (with respect to x) direction, you should wind up with the same +-- direction. +prop_four_cwx_is_identity :: Cardinal -> Bool +prop_four_cwx_is_identity c = + (cwx . cwx . cwx . cwx) c == c + +-- | If you rotate a cardinal direction four times in the +-- counter-clockwise (with respect to x) direction, you should wind up +-- with the same direction. +prop_four_ccwx_is_identity :: Cardinal -> Bool +prop_four_ccwx_is_identity c = + (ccwx . ccwx . ccwx . ccwx) c == c + +-- | If you rotate a cardinal direction four times in the clockwise +-- (with respect to y) direction, you should wind up with the same +-- direction. +prop_four_cwy_is_identity :: Cardinal -> Bool +prop_four_cwy_is_identity c = + (cwy . cwy . cwy . cwy) c == c + +-- | If you rotate a cardinal direction four times in the counter-clockwise +-- (with respect to y) direction, you should wind up with the same +-- direction. +prop_four_ccwy_is_identity :: Cardinal -> Bool +prop_four_ccwy_is_identity c = + (ccwy . ccwy . ccwy . ccwy) c == c + +-- | If you rotate a cardinal direction four times in the clockwise +-- (with respect to z) direction, you should wind up with the same +-- direction. +prop_four_cwz_is_identity :: Cardinal -> Bool +prop_four_cwz_is_identity c = + (cwz . cwz . cwz . cwz) c == c + +-- | If you rotate a cardinal direction four times in the +-- counter-clockwise (with respect to z) direction, you should wind up +-- with the same direction. +prop_four_ccwz_is_identity :: Cardinal -> Bool +prop_four_ccwz_is_identity c = + (ccwz . ccwz . ccwz . ccwz) c == c + + +cardinal_tests :: Test.Framework.Test +cardinal_tests = + testGroup "Cardinal Tests" [ + testCase "c-tilde_2100 rotation correct"test_c_tilde_2100_rotation_correct ] + + +cardinal_properties :: Test.Framework.Test +cardinal_properties = + let tp = testProperty + in + testGroup "Cardinal Properties" [ + tp "ccwx rotation changes direction" prop_ccwx_rotation_changes_direction, + tp "cwx rotation changes direction" prop_cwx_rotation_changes_direction, + tp "ccwy rotation changes direction" prop_ccwy_rotation_changes_direction, + tp "cwy rotation changes direction" prop_cwy_rotation_changes_direction, + tp "ccwz rotation changes direction" prop_ccwz_rotation_changes_direction, + tp "cwz rotation changes direction" prop_cwz_rotation_changes_direction, + tp "ccwx rotation result unique" prop_ccwx_rotation_result_unique, + tp "cwx rotation result unique" prop_cwx_rotation_result_unique, + tp "ccwy rotation result unique" prop_ccwy_rotation_result_unique, + tp "cwy rotation result unique" prop_cwy_rotation_result_unique, + tp "ccwz rotation result unique" prop_ccwz_rotation_result_unique, + tp "cwz rotation result unique" prop_cwz_rotation_result_unique, + tp "four cwx is identity" prop_four_cwx_is_identity, + tp "four ccwx is identity" prop_four_ccwx_is_identity, + tp "four cwy is identity" prop_four_cwy_is_identity, + tp "four ccwy is identity" prop_four_ccwy_is_identity, + tp "four cwz is identity" prop_four_cwz_is_identity, + tp "four ccwz is identity" prop_four_ccwz_is_identity ] diff --git a/src/Tests/Cardinal.hs b/src/Tests/Cardinal.hs deleted file mode 100644 index 7d4cfde..0000000 --- a/src/Tests/Cardinal.hs +++ /dev/null @@ -1,192 +0,0 @@ -module Tests.Cardinal -where - -import Prelude hiding (LT) -import Test.HUnit -import Test.QuickCheck (Property, (==>)) - -import Cardinal - --- | We know what (c t6 2 1 0 0) should be from Sorokina and --- Zeilfelder, p. 87. This test checks that the directions are --- rotated properly. The order of the letters has to be just right --- since I haven't defined a proper Eq instance for Cardinals. -test_c_tilde_2100_rotation_correct :: Assertion -test_c_tilde_2100_rotation_correct = - assertEqual "auto-rotate equals manual rotate" ((ccwz . ccwz . cwy) expr1) expr2 - where - expr1 = - (3/8)*I + - (1/12)*(T + R + L + D) + - (1/64)*(FT + FR + FL + FD) + - (7/48)*F + - (1/48)*B + - (1/96)*(RT + LD + LT + RD) + - (1/192)*(BT + BR + BL + BD) - - expr2 = - (3/8)*I + - (1/12)*(F + L + R + B) + - (1/64)*(FT + LT + RT + BT) + - (7/48)*T + - (1/48)*D + - (1/96)*(FL + BR + FR + BL) + - (1/192)*(FD + LD + RD + BD) - --- | A list of all directions, sans the interior and composite types. -all_directions :: [Cardinal] -all_directions = [L, R, F, B, D, T, FL, FR, FD, FT, - BL, BR, BD, BT, LD, LT, RD, RT, FLD, - FLT, FRD, FRT, BLD, BLT, BRD, BRT] - - --- | If we rotate a direction (other than front or back) --- counter-clockwise with respect to the x-axis, we should get a new --- direction. -prop_ccwx_rotation_changes_direction :: Cardinal -> Property -prop_ccwx_rotation_changes_direction c = - c `elem` [L, R, D, T, FL, FR, FD, FT, BL, BR, BD, BT, LD, LT, - RD, RT, FLD, FLT, FRD, FRT, BLD, BLT, BRD, BRT] - ==> ccwx c /= c - --- | If we rotate a direction (other than front or back) clockwise --- with respect to the x-axis, we should get a new direction. -prop_cwx_rotation_changes_direction :: Cardinal -> Property -prop_cwx_rotation_changes_direction c = - -- The front and back faces are unchanged by x-rotation. - c `elem` [L, R, D, T, FL, FR, FD, FT, BL, BR, BD, BT, LD, LT, - RD, RT, FLD, FLT, FRD, FRT, BLD, BLT, BRD, BRT] - ==> cwx c /= c - --- | If we rotate a direction (other than left or right) --- counter-clockwise with respect to the y-axis, we should get a new --- direction. -prop_ccwy_rotation_changes_direction :: Cardinal -> Property -prop_ccwy_rotation_changes_direction c = - c `elem` [F, B, D, T, FL, FR, FD, FT, BL, BR, BD, BT, LD, LT, - RD, RT, FLD, FLT, FRD, FRT, BLD, BLT, BRD, BRT] - ==> ccwy c /= c - - --- | If we rotate a direction (other than left or right) clockwise --- with respect to the y-axis, we should get a new direction. -prop_cwy_rotation_changes_direction :: Cardinal -> Property -prop_cwy_rotation_changes_direction c = - c `elem` [F, B, D, T, FL, FR, FD, FT, BL, BR, BD, BT, LD, LT, - RD, RT, FLD, FLT, FRD, FRT, BLD, BLT, BRD, BRT] - ==> cwy c /= c - - --- | If we rotate a direction (other than top or down) --- counter-clockwise with respect to the z-axis, we should get a new --- direction. -prop_ccwz_rotation_changes_direction :: Cardinal -> Property -prop_ccwz_rotation_changes_direction c = - c `elem` [L, R, F, B, FL, FR, FD, FT, BL, BR, BD, BT, LD, LT, - RD, RT, FLD, FLT, FRD, FRT, BLD, BLT, BRD, BRT] - ==> ccwz c /= c - - --- | If we rotate a direction (other than top or down) clockwise with --- respect to the z-axis, we should get a new direction. -prop_cwz_rotation_changes_direction :: Cardinal -> Property -prop_cwz_rotation_changes_direction c = - c `elem` [L, R, F, B, FL, FR, FD, FT, BL, BR, BD, BT, LD, LT, - RD, RT, FLD, FLT, FRD, FRT, BLD, BLT, BRD, BRT] - ==> cwz c /= c - - --- | If we are given a direction c, there should only be one direction --- d which, when rotated counter-clockwise with respect to the --- x-axis, produces c. -prop_ccwx_rotation_result_unique :: Cardinal -> Property -prop_ccwx_rotation_result_unique c = - c `elem` all_directions ==> - (length [ d | d <- all_directions, ccwx d == c ]) == 1 - --- | If we are given a direction c, there should only be one direction --- d which, when rotated clockwise with respect to the x-axis, --- produces c. -prop_cwx_rotation_result_unique :: Cardinal -> Property -prop_cwx_rotation_result_unique c = - c `elem` all_directions ==> - (length [ d | d <- all_directions, cwx d == c ]) == 1 - - --- | If we are given a direction c, there should only be one direction --- d which, when rotated counter-clockwise with respect to the --- y-axis, produces c. -prop_ccwy_rotation_result_unique :: Cardinal -> Property -prop_ccwy_rotation_result_unique c = - c `elem` all_directions ==> - (length [ d | d <- all_directions, ccwy d == c ]) == 1 - - --- | If we are given a direction c, there should only be one direction --- d which, when rotated clockwise with respect to the y-axis, --- produces c. -prop_cwy_rotation_result_unique :: Cardinal -> Property -prop_cwy_rotation_result_unique c = - c `elem` all_directions ==> - (length [ d | d <- all_directions, cwy d == c ]) == 1 - - --- | If we are given a direction c, there should only be one direction --- d which, when rotated counter-clockwise with respect to the --- z-axis, produces c. -prop_ccwz_rotation_result_unique :: Cardinal -> Property -prop_ccwz_rotation_result_unique c = - c `elem` all_directions ==> - (length [ d | d <- all_directions, ccwz d == c ]) == 1 - - --- | If we are given a direction c, there should only be one direction --- d which, when rotated clockwise with respect to the z-axis, --- produces c. -prop_cwz_rotation_result_unique :: Cardinal -> Property -prop_cwz_rotation_result_unique c = - c `elem` all_directions ==> - (length [ d | d <- all_directions, cwz d == c ]) == 1 - - --- | If you rotate a cardinal direction four times in the clockwise --- (with respect to x) direction, you should wind up with the same --- direction. -prop_four_cwx_is_identity :: Cardinal -> Bool -prop_four_cwx_is_identity c = - (cwx . cwx . cwx . cwx) c == c - --- | If you rotate a cardinal direction four times in the --- counter-clockwise (with respect to x) direction, you should wind up --- with the same direction. -prop_four_ccwx_is_identity :: Cardinal -> Bool -prop_four_ccwx_is_identity c = - (ccwx . ccwx . ccwx . ccwx) c == c - --- | If you rotate a cardinal direction four times in the clockwise --- (with respect to y) direction, you should wind up with the same --- direction. -prop_four_cwy_is_identity :: Cardinal -> Bool -prop_four_cwy_is_identity c = - (cwy . cwy . cwy . cwy) c == c - --- | If you rotate a cardinal direction four times in the counter-clockwise --- (with respect to y) direction, you should wind up with the same --- direction. -prop_four_ccwy_is_identity :: Cardinal -> Bool -prop_four_ccwy_is_identity c = - (ccwy . ccwy . ccwy . ccwy) c == c - --- | If you rotate a cardinal direction four times in the clockwise --- (with respect to z) direction, you should wind up with the same --- direction. -prop_four_cwz_is_identity :: Cardinal -> Bool -prop_four_cwz_is_identity c = - (cwz . cwz . cwz . cwz) c == c - --- | If you rotate a cardinal direction four times in the --- counter-clockwise (with respect to z) direction, you should wind up --- with the same direction. -prop_four_ccwz_is_identity :: Cardinal -> Bool -prop_four_ccwz_is_identity c = - (ccwz . ccwz . ccwz . ccwz) c == c diff --git a/test/TestSuite.hs b/test/TestSuite.hs index a3563b0..25057ef 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -9,9 +9,9 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit import Test.QuickCheck (Testable ()) +import Cardinal (cardinal_tests, cardinal_properties) import FunctionValues (function_values_tests, function_values_properties) import Misc (misc_tests, misc_properties) -import Tests.Cardinal import Tests.Cube as TC import Tests.Grid import Tests.Tetrahedron as TT @@ -25,10 +25,6 @@ main = do tc :: Test.Framework.Providers.API.TestName -> Test.HUnit.Assertion -> Test.Framework.Test tc = testCase -cardinal_tests :: Test.Framework.Test -cardinal_tests = - testGroup "Cardinal Tests" [ - tc "c-tilde_2100 rotation correct" test_c_tilde_2100_rotation_correct ] grid_tests :: Test.Framework.Test @@ -53,29 +49,6 @@ tp :: Test.QuickCheck.Testable a => Test.Framework.TestName -> a -> Test.Framewo tp = testProperty -cardinal_properties :: Test.Framework.Test -cardinal_properties = - testGroup "Cardinal Properties" [ - tp "ccwx rotation changes direction" prop_ccwx_rotation_changes_direction, - tp "cwx rotation changes direction" prop_cwx_rotation_changes_direction, - tp "ccwy rotation changes direction" prop_ccwy_rotation_changes_direction, - tp "cwy rotation changes direction" prop_cwy_rotation_changes_direction, - tp "ccwz rotation changes direction" prop_ccwz_rotation_changes_direction, - tp "cwz rotation changes direction" prop_cwz_rotation_changes_direction, - tp "ccwx rotation result unique" prop_ccwx_rotation_result_unique, - tp "cwx rotation result unique" prop_cwx_rotation_result_unique, - tp "ccwy rotation result unique" prop_ccwy_rotation_result_unique, - tp "cwy rotation result unique" prop_cwy_rotation_result_unique, - tp "ccwz rotation result unique" prop_ccwz_rotation_result_unique, - tp "cwz rotation result unique" prop_cwz_rotation_result_unique, - tp "four cwx is identity" prop_four_cwx_is_identity, - tp "four ccwx is identity" prop_four_ccwx_is_identity, - tp "four cwy is identity" prop_four_cwy_is_identity, - tp "four ccwy is identity" prop_four_ccwy_is_identity, - tp "four cwz is identity" prop_four_cwz_is_identity, - tp "four ccwz is identity" prop_four_ccwz_is_identity] - - p78_24_properties :: Test.Framework.Test p78_24_properties = testGroup "p. 78, Section (2.4) Properties" [ -- 2.44.2