From 190b6c22ab150e1877b0b94a33253832eb7764d2 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Sat, 7 May 2011 13:35:13 -0400 Subject: [PATCH] Rework a bunch of Cube stuff and re-enable now-passing tests. --- src/Cube.hs | 93 ++++++++++++++++++++++++--------------------- src/Tests/Cube.hs | 77 +++++++++++++++++++++++++++---------- test/TestSuite.hs | 97 ++++++++++++++++++++++++++++------------------- 3 files changed, 164 insertions(+), 103 deletions(-) diff --git a/src/Cube.hs b/src/Cube.hs index 8d978f7..ad3d3c7 100644 --- a/src/Cube.hs +++ b/src/Cube.hs @@ -2,10 +2,10 @@ module Cube where import Cardinal -import Face (Face(Face, v0, v1, v2, v3)) +import qualified Face (Face(Face, v0, v1, v2, v3)) import FunctionValues import Point -import Tetrahedron (Tetrahedron(Tetrahedron), fv) +import Tetrahedron hiding (c) import ThreeDimensional data Cube = Cube { h :: Double, @@ -26,7 +26,8 @@ instance Show Cube where " ymin: " ++ (show (ymin c)) ++ "\n" ++ " ymax: " ++ (show (ymax c)) ++ "\n" ++ " zmin: " ++ (show (zmin c)) ++ "\n" ++ - " zmax: " ++ (show (zmax c)) ++ "\n" + " zmax: " ++ (show (zmax c)) ++ "\n" ++ + " fv: " ++ (show (Cube.fv c)) ++ "\n" where subscript = (show (i c)) ++ "," ++ (show (j c)) ++ "," ++ (show (k c)) @@ -111,20 +112,20 @@ instance ThreeDimensional Cube where -- Face stuff. -- | The top (in the direction of z) face of the cube. -top_face :: Cube -> Face -top_face c = Face v0' v1' v2' v3' +top_face :: Cube -> Face.Face +top_face c = Face.Face v0' v1' v2' v3' where delta = (1/2)*(h c) - v0' = (center c) + (delta, delta, delta) - v1' = (center c) + (delta, -delta, delta) - v2' = (center c) + (-delta, -delta, delta) - v3' = (center c) + (-delta, delta, delta) + v0' = (center c) + (delta, -delta, delta) + v1' = (center c) + (delta, delta, delta) + v2' = (center c) + (-delta, delta, delta) + v3' = (center c) + (-delta, -delta, delta) -- | The back (in the direction of x) face of the cube. -back_face :: Cube -> Face -back_face c = Face v0' v1' v2' v3' +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) @@ -134,8 +135,8 @@ back_face c = Face v0' v1' v2' v3' -- The bottom face (in the direction of -z) of the cube. -down_face :: Cube -> Face -down_face c = Face v0' v1' v2' v3' +down_face :: Cube -> Face.Face +down_face c = Face.Face v0' v1' v2' v3' where delta = (1/2)*(h c) v0' = (center c) + (delta, delta, -delta) @@ -146,8 +147,8 @@ down_face c = Face v0' v1' v2' v3' -- | The front (in the direction of -x) face of the cube. -front_face :: Cube -> Face -front_face c = Face v0' v1' v2' v3' +front_face :: Cube -> Face.Face +front_face c = Face.Face v0' v1' v2' v3' where delta = (1/2)*(h c) v0' = (center c) + (-delta, -delta, delta) @@ -155,10 +156,9 @@ front_face c = Face v0' v1' v2' v3' v2' = (center c) + (-delta, delta, -delta) v3' = (center c) + (-delta, -delta, -delta) - -- | The left (in the direction of -y) face of the cube. -left_face :: Cube -> Face -left_face c = Face v0' v1' v2' v3' +left_face :: Cube -> Face.Face +left_face c = Face.Face v0' v1' v2' v3' where delta = (1/2)*(h c) v0' = (center c) + (-delta, -delta, delta) @@ -168,8 +168,8 @@ left_face c = Face v0' v1' v2' v3' -- | The right (in the direction of y) face of the cube. -right_face :: Cube -> Face -right_face c = Face v0' v1' v2' v3' +right_face :: Cube -> Face.Face +right_face c = Face.Face v0' v1' v2' v3' where delta = (1/2)*(h c) v0' = (center c) + (-delta, delta, -delta) @@ -178,84 +178,89 @@ right_face c = 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 = - Tetrahedron (Cube.fv c) v0' v1' v2' v3' + reorient $ Tetrahedron (Cube.fv c) v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) - v2' = v0 (front_face c) - v3' = v1 (front_face c) + v2' = Face.v0 (front_face c) + v3' = Face.v1 (front_face c) tetrahedron1 :: Cube -> Tetrahedron tetrahedron1 c = - Tetrahedron fv' v0' v1' v2' v3' + reorient $ Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) - v2' = v1 (front_face c) - v3' = v2 (front_face c) + v2' = Face.v1 (front_face c) + v3' = Face.v2 (front_face c) fv' = rotate (Cube.fv c) ccwx tetrahedron2 :: Cube -> Tetrahedron tetrahedron2 c = - Tetrahedron fv' v0' v1' v2' v3' + reorient $ Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) - v2' = v2 (front_face c) - v3' = v3 (front_face c) + v2' = Face.v2 (front_face c) + v3' = Face.v3 (front_face c) fv' = rotate (Cube.fv c) (ccwx . ccwx) tetrahedron3 :: Cube -> Tetrahedron tetrahedron3 c = - Tetrahedron fv' v0' v1' v2' v3' + reorient $ Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (front_face c) - v2' = v3 (front_face c) - v3' = v1 (front_face c) + v2' = Face.v3 (front_face c) + v3' = Face.v0 (front_face c) fv' = rotate (Cube.fv c) cwx tetrahedron4 :: Cube -> Tetrahedron tetrahedron4 c = - Tetrahedron fv' v0' v1' v2' v3' + reorient $ Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) - v2' = v0 (front_face c) - v3' = v1 (front_face c) + v2' = Face.v0 (top_face c) + v3' = Face.v1 (top_face c) fv' = rotate (Cube.fv c) cwy tetrahedron5 :: Cube -> Tetrahedron tetrahedron5 c = - Tetrahedron fv' v0' v1' v2' v3' + reorient $ Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) - v2' = v1 (top_face c) - v3' = v2 (top_face c) + v2' = Face.v1 (top_face c) + v3' = Face.v2 (top_face c) fv' = rotate (Tetrahedron.fv (tetrahedron0 c)) ccwx tetrahedron6 :: Cube -> Tetrahedron tetrahedron6 c = - Tetrahedron fv' v0' v1' v2' v3' + reorient $ Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) - v2' = v2 (top_face c) - v3' = v3 (top_face c) + v2' = Face.v2 (top_face c) + v3' = Face.v3 (top_face c) fv' = rotate (Tetrahedron.fv (tetrahedron0 c)) (ccwx . ccwx) tetrahedron7 :: Cube -> Tetrahedron tetrahedron7 c = - Tetrahedron fv' v0' v1' v2' v3' + reorient $ Tetrahedron fv' v0' v1' v2' v3' where v0' = center c v1' = center (top_face c) - v2' = v3 (top_face c) - v3' = v1 (top_face c) + v2' = Face.v3 (top_face c) + v3' = Face.v0 (top_face c) fv' = rotate (Tetrahedron.fv (tetrahedron0 c)) cwx tetrahedrons :: Cube -> [Tetrahedron] diff --git a/src/Tests/Cube.hs b/src/Tests/Cube.hs index 3cfefd4..b788884 100644 --- a/src/Tests/Cube.hs +++ b/src/Tests/Cube.hs @@ -3,6 +3,7 @@ where import Test.QuickCheck +import Comparisons import Cube import FunctionValues (FunctionValues(FunctionValues)) import Tests.FunctionValues @@ -26,15 +27,24 @@ instance Arbitrary Cube where -- | Since the grid size is necessarily positive, all tetrahedrons -- (which comprise cubes of positive volume) must have positive volume -- as well. -prop_all_volumes_positive :: Cube -> Property +prop_all_volumes_positive :: Cube -> Bool prop_all_volumes_positive c = - (delta > 0) ==> (null nonpositive_volumes) + null nonpositive_volumes where - delta = h c ts = tetrahedrons c volumes = map volume ts nonpositive_volumes = filter (<= 0) volumes +-- | In fact, since all of the tetrahedra are identical, we should +-- already know their volumes. There's 24 tetrahedra to a cube, so +-- we'd expect the volume of each one to be (1/24)*h^3. +prop_all_volumes_exact :: Cube -> Bool +prop_all_volumes_exact c = + volume t ~= (1/24)*(delta^(3::Int)) + where + t = head $ tetrahedrons c + delta = h c + -- | All tetrahedron should have their v0 located at the center of the cube. prop_v0_all_equal :: Cube -> Bool prop_v0_all_equal c = (v0 t0) == (v0 t1) @@ -44,24 +54,49 @@ prop_v0_all_equal c = (v0 t0) == (v0 t1) -- | This pretty much repeats the prop_all_volumes_positive property, --- but will let me know which face's vertices are disoriented. -prop_front_face_volumes_positive :: Cube -> Property -prop_front_face_volumes_positive c = - (delta > 0) ==> (null nonpositive_volumes) - where - delta = h c - ts = [tetrahedron0 c, tetrahedron1 c, tetrahedron2 c, tetrahedron3 c] - volumes = map volume ts - nonpositive_volumes = filter (<= 0) volumes +-- but will let me know which tetrahedrons's vertices are disoriented. +prop_tetrahedron0_volumes_positive :: Cube -> Bool +prop_tetrahedron0_volumes_positive c = + volume (tetrahedron0 c) > 0 +-- | This pretty much repeats the prop_all_volumes_positive property, +-- but will let me know which tetrahedrons's vertices are disoriented. +prop_tetrahedron1_volumes_positive :: Cube -> Bool +prop_tetrahedron1_volumes_positive c = + volume (tetrahedron1 c) > 0 -- | This pretty much repeats the prop_all_volumes_positive property, --- but will let me know which face's vertices are disoriented. -prop_top_face_volumes_positive :: Cube -> Property -prop_top_face_volumes_positive c = - (delta > 0) ==> (null nonpositive_volumes) - where - delta = h c - ts = [tetrahedron4 c, tetrahedron5 c, tetrahedron6 c, tetrahedron7 c] - volumes = map volume ts - nonpositive_volumes = filter (<= 0) volumes +-- but will let me know which tetrahedrons's vertices are disoriented. +prop_tetrahedron2_volumes_positive :: Cube -> Bool +prop_tetrahedron2_volumes_positive c = + volume (tetrahedron2 c) > 0 + +-- | This pretty much repeats the prop_all_volumes_positive property, +-- but will let me know which tetrahedrons's vertices are disoriented. +prop_tetrahedron3_volumes_positive :: Cube -> Bool +prop_tetrahedron3_volumes_positive c = + volume (tetrahedron3 c) > 0 + +-- | This pretty much repeats the prop_all_volumes_positive property, +-- but will let me know which tetrahedrons's vertices are disoriented. +prop_tetrahedron4_volumes_positive :: Cube -> Bool +prop_tetrahedron4_volumes_positive c = + volume (tetrahedron4 c) > 0 + +-- | This pretty much repeats the prop_all_volumes_positive property, +-- but will let me know which tetrahedrons's vertices are disoriented. +prop_tetrahedron5_volumes_positive :: Cube -> Bool +prop_tetrahedron5_volumes_positive c = + volume (tetrahedron5 c) > 0 + +-- | This pretty much repeats the prop_all_volumes_positive property, +-- but will let me know which tetrahedrons's vertices are disoriented. +prop_tetrahedron6_volumes_positive :: Cube -> Bool +prop_tetrahedron6_volumes_positive c = + volume (tetrahedron6 c) > 0 + +-- | This pretty much repeats the prop_all_volumes_positive property, +-- but will let me know which tetrahedrons's vertices are disoriented. +prop_tetrahedron7_volumes_positive :: Cube -> Bool +prop_tetrahedron7_volumes_positive c = + volume (tetrahedron7 c) > 0 diff --git a/test/TestSuite.hs b/test/TestSuite.hs index e125526..3e958e1 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -27,65 +27,86 @@ main = do putStr "prop_all_volumes_positive... " quickCheckWith qc_args prop_all_volumes_positive - putStr "prop_front_face_volumes_positive... " - quickCheckWith qc_args prop_front_face_volumes_positive + putStr "prop_all_volumes_exact... " + quickCheckWith qc_args prop_all_volumes_exact - putStr "prop_top_face_volumes_positive... " - quickCheckWith qc_args prop_top_face_volumes_positive + putStr "prop_tetrahedron0_volumes_positive... " + quickCheckWith qc_args prop_tetrahedron0_volumes_positive + + putStr "prop_tetrahedron1_volumes_positive... " + quickCheckWith qc_args prop_tetrahedron1_volumes_positive + + putStr "prop_tetrahedron2_volumes_positive... " + quickCheckWith qc_args prop_tetrahedron2_volumes_positive + + putStr "prop_tetrahedron3_volumes_positive... " + quickCheckWith qc_args prop_tetrahedron3_volumes_positive + + putStr "prop_tetrahedron4_volumes_positive... " + quickCheckWith qc_args prop_tetrahedron4_volumes_positive + + putStr "prop_tetrahedron5_volumes_positive... " + quickCheckWith qc_args prop_tetrahedron5_volumes_positive + + putStr "prop_tetrahedron6_volumes_positive... " + quickCheckWith qc_args prop_tetrahedron6_volumes_positive + + putStr "prop_tetrahedron7_volumes_positive... " + quickCheckWith qc_args prop_tetrahedron7_volumes_positive putStr "prop_v0_all_equal... " quickCheckWith qc_args prop_v0_all_equal - -- putStr "prop_factorial_greater... " - -- quickCheckWith qc_args prop_factorial_greater + putStr "prop_factorial_greater... " + quickCheckWith qc_args prop_factorial_greater - -- putStr "prop_b0_v0_always_unity... " - -- quickCheckWith qc_args prop_b0_v0_always_unity + putStr "prop_b0_v0_always_unity... " + quickCheckWith qc_args prop_b0_v0_always_unity - -- putStr "prop_b0_v1_always_zero... " - -- quickCheckWith qc_args prop_b0_v1_always_zero + putStr "prop_b0_v1_always_zero... " + quickCheckWith qc_args prop_b0_v1_always_zero - -- putStr "prop_b0_v2_always_zero... " - -- quickCheckWith qc_args prop_b0_v2_always_zero + putStr "prop_b0_v2_always_zero... " + quickCheckWith qc_args prop_b0_v2_always_zero - -- putStr "prop_b0_v3_always_zero... " - -- quickCheckWith qc_args prop_b0_v3_always_zero + putStr "prop_b0_v3_always_zero... " + quickCheckWith qc_args prop_b0_v3_always_zero - -- putStr "prop_b1_v1_always_unity... " - -- quickCheckWith qc_args prop_b1_v1_always_unity + putStr "prop_b1_v1_always_unity... " + quickCheckWith qc_args prop_b1_v1_always_unity - -- putStr "prop_b1_v0_always_zero... " - -- quickCheckWith qc_args prop_b1_v0_always_zero + putStr "prop_b1_v0_always_zero... " + quickCheckWith qc_args prop_b1_v0_always_zero - -- putStr "prop_b1_v2_always_zero... " - -- quickCheckWith qc_args prop_b1_v2_always_zero + putStr "prop_b1_v2_always_zero... " + quickCheckWith qc_args prop_b1_v2_always_zero - -- putStr "prop_b1_v3_always_zero... " - -- quickCheckWith qc_args prop_b1_v3_always_zero + putStr "prop_b1_v3_always_zero... " + quickCheckWith qc_args prop_b1_v3_always_zero - -- putStr "prop_b2_v2_always_unity... " - -- quickCheckWith qc_args prop_b2_v2_always_unity + putStr "prop_b2_v2_always_unity... " + quickCheckWith qc_args prop_b2_v2_always_unity - -- putStr "prop_b2_v0_always_zero... " - -- quickCheckWith qc_args prop_b2_v0_always_zero + putStr "prop_b2_v0_always_zero... " + quickCheckWith qc_args prop_b2_v0_always_zero - -- putStr "prop_b2_v1_always_zero... " - -- quickCheckWith qc_args prop_b2_v1_always_zero + putStr "prop_b2_v1_always_zero... " + quickCheckWith qc_args prop_b2_v1_always_zero - -- putStr "prop_b2_v3_always_zero... " - -- quickCheckWith qc_args prop_b2_v3_always_zero + putStr "prop_b2_v3_always_zero... " + quickCheckWith qc_args prop_b2_v3_always_zero - -- putStr "prop_b3_v3_always_unity... " - -- quickCheckWith qc_args prop_b3_v3_always_unity + putStr "prop_b3_v3_always_unity... " + quickCheckWith qc_args prop_b3_v3_always_unity - -- putStr "prop_b3_v0_always_zero... " - -- quickCheckWith qc_args prop_b3_v0_always_zero + putStr "prop_b3_v0_always_zero... " + quickCheckWith qc_args prop_b3_v0_always_zero - -- putStr "prop_b3_v1_always_zero... " - -- quickCheckWith qc_args prop_b3_v1_always_zero + putStr "prop_b3_v1_always_zero... " + quickCheckWith qc_args prop_b3_v1_always_zero - -- putStr "prop_b3_v2_always_zero... " - -- quickCheckWith qc_args prop_b3_v2_always_zero + putStr "prop_b3_v2_always_zero... " + quickCheckWith qc_args prop_b3_v2_always_zero -- putStrLn "\np. 78, (2.4)\n" -- 2.43.2