From: Michael Orlitzky <michael@orlitzky.com>
Date: Sat, 7 May 2011 17:35:13 +0000 (-0400)
Subject: Rework a bunch of Cube stuff and re-enable now-passing tests.
X-Git-Tag: 0.0.1~326
X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=190b6c22ab150e1877b0b94a33253832eb7764d2;p=spline3.git

Rework a bunch of Cube stuff and re-enable now-passing tests.
---

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"