From 51adbba172ccaa70c4832809de334674a8ba6a0f Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Sat, 7 May 2011 16:04:30 -0400 Subject: [PATCH] Remove the 'reorient' function from Cube. Add tetrahedron functions 8 through 11. Add some tests for the volumes of tetrahedron 8 through 11 to the suite. --- src/Cube.hs | 87 +++++++++++++++++++++++++++++++++-------------- test/TestSuite.hs | 38 +++++++++++++++++++++ 2 files changed, 99 insertions(+), 26 deletions(-) diff --git a/src/Cube.hs b/src/Cube.hs index ad3d3c7..8287177 100644 --- a/src/Cube.hs +++ b/src/Cube.hs @@ -128,9 +128,9 @@ back_face :: Cube -> Face.Face back_face c = Face.Face v0' v1' v2' v3' where delta = (1/2)*(h c) - v0' = (center c) + (delta, delta, delta) + v0' = (center c) + (delta, -delta, -delta) v1' = (center c) + (delta, delta, -delta) - v2' = (center c) + (delta, -delta, -delta) + v2' = (center c) + (delta, delta, delta) v3' = (center c) + (delta, -delta, delta) @@ -178,15 +178,9 @@ right_face c = Face.Face v0' v1' v2' v3' v3' = (center c) + (-delta, delta, delta) -reorient :: Tetrahedron -> Tetrahedron -reorient t = t --- | volume t > 0 = t --- | otherwise = t { v2 = (v3 t), --- v3 = (v2 t) } - tetrahedron0 :: Cube -> Tetrahedron tetrahedron0 c = - reorient $ Tetrahedron (Cube.fv c) v0' v1' v2' v3' + Tetrahedron (Cube.fv c) v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) @@ -195,7 +189,7 @@ tetrahedron0 c = tetrahedron1 :: Cube -> Tetrahedron tetrahedron1 c = - reorient $ Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) @@ -205,7 +199,7 @@ tetrahedron1 c = tetrahedron2 :: Cube -> Tetrahedron tetrahedron2 c = - reorient $ Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) @@ -215,7 +209,7 @@ tetrahedron2 c = tetrahedron3 :: Cube -> Tetrahedron tetrahedron3 c = - reorient $ Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) @@ -225,7 +219,7 @@ tetrahedron3 c = tetrahedron4 :: Cube -> Tetrahedron tetrahedron4 c = - reorient $ Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) @@ -235,33 +229,75 @@ tetrahedron4 c = tetrahedron5 :: Cube -> Tetrahedron tetrahedron5 c = - reorient $ Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) v2' = Face.v1 (top_face c) v3' = Face.v2 (top_face c) - fv' = rotate (Tetrahedron.fv (tetrahedron0 c)) ccwx + fv' = rotate (Tetrahedron.fv (tetrahedron4 c)) ccwz tetrahedron6 :: Cube -> Tetrahedron tetrahedron6 c = - reorient $ Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) v2' = Face.v2 (top_face c) v3' = Face.v3 (top_face c) - fv' = rotate (Tetrahedron.fv (tetrahedron0 c)) (ccwx . ccwx) + fv' = rotate (Tetrahedron.fv (tetrahedron4 c)) (ccwz . ccwz) tetrahedron7 :: Cube -> Tetrahedron tetrahedron7 c = - reorient $ Tetrahedron fv' v0' v1' v2' v3' + Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) v2' = Face.v3 (top_face c) v3' = Face.v0 (top_face c) - fv' = rotate (Tetrahedron.fv (tetrahedron0 c)) cwx + fv' = rotate (Tetrahedron.fv (tetrahedron4 c)) cwz + +tetrahedron8 :: Cube -> Tetrahedron +tetrahedron8 c = + Tetrahedron fv' v0' v1' v2' v3' + where + v0' = center c + v1' = center (back_face c) + v2' = Face.v0 (back_face c) + v3' = Face.v1 (back_face c) + fv' = rotate (Tetrahedron.fv (tetrahedron4 c)) cwy + +tetrahedron9 :: Cube -> Tetrahedron +tetrahedron9 c = + Tetrahedron fv' v0' v1' v2' v3' + where + v0' = center c + v1' = center (back_face c) + v2' = Face.v1 (back_face c) + v3' = Face.v2 (back_face c) + fv' = rotate (Tetrahedron.fv (tetrahedron8 c)) ccwx + +tetrahedron10 :: Cube -> Tetrahedron +tetrahedron10 c = + Tetrahedron fv' v0' v1' v2' v3' + where + v0' = center c + v1' = center (back_face c) + v2' = Face.v2 (back_face c) + v3' = Face.v3 (back_face c) + fv' = rotate (Tetrahedron.fv (tetrahedron8 c)) (ccwx . ccwx) + + +tetrahedron11 :: Cube -> Tetrahedron +tetrahedron11 c = + Tetrahedron fv' v0' v1' v2' v3' + where + v0' = center c + v1' = center (back_face c) + v2' = Face.v3 (back_face c) + v3' = Face.v0 (back_face c) + fv' = rotate (Tetrahedron.fv (tetrahedron8 c)) cwx + tetrahedrons :: Cube -> [Tetrahedron] tetrahedrons c = @@ -272,13 +308,12 @@ tetrahedrons c = tetrahedron4 c, tetrahedron5 c, tetrahedron6 c, - tetrahedron7 c - -- , - -- tetrahedron8 c, - -- tetrahedron9 c, - -- tetrahedron10 c, - -- tetrahedron11 c, - -- tetrahedron12 c, + tetrahedron7 c, + tetrahedron8 c, + tetrahedron9 c, + tetrahedron10 c, + tetrahedron11 c + --tetrahedron12 c, -- tetrahedron13 c, -- tetrahedron14 c, -- tetrahedron15 c, diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 57988c3..a73480d 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -24,6 +24,8 @@ main = do maxDiscard = 500, maxSize = 100 } + putStrLn "\nCube Tests\n" + putStr "prop_all_volumes_positive... " quickCheckWith qc_args prop_all_volumes_positive @@ -78,12 +80,28 @@ main = do putStr "prop_tetrahedron7_volumes_positive... " quickCheckWith qc_args prop_tetrahedron7_volumes_positive + putStr "prop_tetrahedron8_volumes_positive... " + quickCheckWith qc_args prop_tetrahedron8_volumes_positive + + putStr "prop_tetrahedron9_volumes_positive... " + quickCheckWith qc_args prop_tetrahedron9_volumes_positive + + putStr "prop_tetrahedron10_volumes_positive... " + quickCheckWith qc_args prop_tetrahedron10_volumes_positive + + putStr "prop_tetrahedron11_volumes_positive... " + quickCheckWith qc_args prop_tetrahedron11_volumes_positive + putStr "prop_v0_all_equal... " quickCheckWith qc_args prop_v0_all_equal + putStrLn "\nMisc Tests\n" + putStr "prop_factorial_greater... " quickCheckWith qc_args prop_factorial_greater + putStrLn "\nTetrahedron Tests\n" + putStr "prop_b0_v0_always_unity... " quickCheckWith qc_args prop_b0_v0_always_unity @@ -227,10 +245,30 @@ main = do -- putStr "prop_c0300_identity3... " -- quickCheckWith qc_args TF.prop_c0300_identity3 + putStrLn "\nCardinal Tests\n" + putStr "prop_ccwx_rotation_changes_direction... " quickCheckWith qc_args prop_ccwx_rotation_changes_direction putStr "prop_cwx_rotation_changes_direction... " quickCheckWith qc_args prop_cwx_rotation_changes_direction + putStr "prop_four_cwx_is_identity... " + quickCheckWith qc_args prop_four_cwx_is_identity + + putStr "prop_four_ccwx_is_identity... " + quickCheckWith qc_args prop_four_ccwx_is_identity + + putStr "prop_four_cwy_is_identity... " + quickCheckWith qc_args prop_four_cwy_is_identity + + putStr "prop_four_ccwy_is_identity... " + quickCheckWith qc_args prop_four_ccwy_is_identity + + putStr "prop_four_cwz_is_identity... " + quickCheckWith qc_args prop_four_cwz_is_identity + + putStr "prop_four_ccwz_is_identity... " + quickCheckWith qc_args prop_four_ccwz_is_identity + return () -- 2.43.2