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.

diff --git a/src/Cube.hs b/src/Cube.hs
index ad3d3c7567a343f57a5ecbcda85394b96500b06d..8287177ed17edf6307a9517d06e11548320fa7da 100644 (file)
--- 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 57988c35bafc16e7bea6657b80201b9a83adadfa..a73480d87205b8201765e08283dad9adefe48dae 100644 (file)
--- 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 ()