X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FCube.hs;h=552b141e2a2f597ce7669baa9e181259e2979a96;hb=dbb641b1534f7b3a24d5b6f4479b91f1fd681c54;hp=6652e8b6331f039cd90cd9c7791dab61f2fd3f58;hpb=d9eed953bd810f6928de536617dc21121a8a645b;p=spline3.git diff --git a/src/Cube.hs b/src/Cube.hs index 6652e8b..552b141 100644 --- a/src/Cube.hs +++ b/src/Cube.hs @@ -1,13 +1,17 @@ +-- The "tetrahedron" function pattern matches on the integers zero +-- through twenty-three, but doesn't handle the "otherwise" case, for +-- performance reasons. +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + module Cube ( Cube(..), cube_properties, find_containing_tetrahedron, tetrahedra, - tetrahedron - ) + tetrahedron ) where -import Data.Maybe (fromJust) +import Data.Maybe ( fromJust ) import qualified Data.Vector as V ( Vector, findIndex, @@ -15,20 +19,34 @@ import qualified Data.Vector as V ( minimum, singleton, snoc, - unsafeIndex - ) -import Prelude hiding (LT) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Arbitrary(..), Gen, Positive(..), choose) - -import Cardinal -import Comparisons ((~=), (~~=)) -import qualified Face (Face(..), center) -import FunctionValues (FunctionValues, eval, rotate) -import Misc (all_equal, disjoint) -import Point (Point(..), dot) -import Tetrahedron (Tetrahedron(..), barycenter, c, volume) + unsafeIndex) +import Prelude hiding ( LT ) +import Test.Tasty ( TestTree, testGroup ) +import Test.Tasty.QuickCheck ( + Arbitrary( arbitrary ), + Gen, + Positive( Positive ), + choose, + testProperty ) +import Cardinal ( + Cardinal(F, B, L, R, D, T, FL, FR, FD, FT, + BL, BR, BD, BT, LD, LT, RD, RT, I), + ccwx, + ccwy, + ccwz, + cwx, + cwy, + cwz ) +import Comparisons ( (~=), (~~=) ) +import qualified Face ( Face(..), center ) +import FunctionValues ( FunctionValues, eval, rotate ) +import Misc ( all_equal, disjoint ) +import Point ( Point( Point ), dot ) +import Tetrahedron ( + Tetrahedron(Tetrahedron, function_values, v0, v1, v2, v3), + barycenter, + c, + volume ) data Cube = Cube { i :: !Int, j :: !Int, @@ -51,7 +69,7 @@ instance Arbitrary Cube where -- these numbers don't overflow 64 bits. This number is not -- magic in any other sense than that it does not cause test -- failures, while 2^23 does. - coordmax = 4194304 -- 2^22 + coordmax = 4194304 :: Int -- 2^22 coordmin = -coordmax @@ -130,7 +148,7 @@ center cube = top_face :: Cube -> Face.Face top_face cube = Face.Face v0' v1' v2' v3' where - delta = 1/2 + delta = (1/2) :: Double cc = center cube v0' = cc + ( Point delta (-delta) delta ) v1' = cc + ( Point delta delta delta ) @@ -143,7 +161,7 @@ top_face cube = Face.Face v0' v1' v2' v3' back_face :: Cube -> Face.Face back_face cube = Face.Face v0' v1' v2' v3' where - delta = 1/2 + delta = (1/2) :: Double cc = center cube v0' = cc + ( Point delta (-delta) (-delta) ) v1' = cc + ( Point delta delta (-delta) ) @@ -155,7 +173,7 @@ back_face cube = Face.Face v0' v1' v2' v3' down_face :: Cube -> Face.Face down_face cube = Face.Face v0' v1' v2' v3' where - delta = 1/2 + delta = (1/2) :: Double cc = center cube v0' = cc + ( Point (-delta) (-delta) (-delta) ) v1' = cc + ( Point (-delta) delta (-delta) ) @@ -168,7 +186,7 @@ down_face cube = Face.Face v0' v1' v2' v3' front_face :: Cube -> Face.Face front_face cube = Face.Face v0' v1' v2' v3' where - delta = 1/2 + delta = (1/2) :: Double cc = center cube v0' = cc + ( Point (-delta) (-delta) delta ) v1' = cc + ( Point (-delta) delta delta ) @@ -179,7 +197,7 @@ front_face cube = Face.Face v0' v1' v2' v3' left_face :: Cube -> Face.Face left_face cube = Face.Face v0' v1' v2' v3' where - delta = 1/2 + delta = (1/2) :: Double cc = center cube v0' = cc + ( Point delta (-delta) delta ) v1' = cc + ( Point (-delta) (-delta) delta ) @@ -191,7 +209,7 @@ left_face cube = Face.Face v0' v1' v2' v3' right_face :: Cube -> Face.Face right_face cube = Face.Face v0' v1' v2' v3' where - delta = 1/2 + delta = (1/2) :: Double cc = center cube v0' = cc + ( Point (-delta) delta delta) v1' = cc + ( Point delta delta delta ) @@ -603,9 +621,8 @@ find_containing_tetrahedron cube p = left_half = in_left_half cube p candidates :: V.Vector Tetrahedron - candidates = - if front_half then - + candidates + | front_half = if left_half then if top_half then front_left_top_tetrahedra cube @@ -617,8 +634,7 @@ find_containing_tetrahedron cube p = else front_right_down_tetrahedra cube - else -- bottom half - + | otherwise = -- back half if left_half then if top_half then back_left_top_tetrahedra cube @@ -654,9 +670,7 @@ find_containing_tetrahedron cube p = --- Tests - --- Quickcheck tests. +-- * Tests prop_opposite_octant_tetrahedra_disjoint1 :: Cube -> Bool prop_opposite_octant_tetrahedra_disjoint1 cube = @@ -976,7 +990,7 @@ prop_interior_values_all_identical cube = -- This test checks the rotation works as expected. prop_c_tilde_2100_rotation_correct :: Cube -> Bool prop_c_tilde_2100_rotation_correct cube = - expr1 == expr2 + expr1 ~= expr2 where t0 = tetrahedron cube 0 t6 = tetrahedron cube 6 @@ -1010,7 +1024,7 @@ prop_c_tilde_2100_rotation_correct cube = -- even meaningful! prop_c_tilde_2100_correct :: Cube -> Bool prop_c_tilde_2100_correct cube = - c t6 2 1 0 0 == expected + c t6 2 1 0 0 ~= expected where t0 = tetrahedron cube 0 t6 = tetrahedron cube 6 @@ -1132,9 +1146,9 @@ prop_t7_shares_edge_with_t20 cube = t20 = tetrahedron cube 20 -p79_26_properties :: Test.Framework.Test +p79_26_properties :: TestTree p79_26_properties = - testGroup "p. 79, Section (2.6) Properties" [ + testGroup "p. 79, Section (2.6) properties" [ testProperty "c0120 identity1" prop_c0120_identity1, testProperty "c0120 identity2" prop_c0120_identity2, testProperty "c0120 identity3" prop_c0120_identity3, @@ -1148,9 +1162,9 @@ p79_26_properties = testProperty "c1200 identity1" prop_c1200_identity1, testProperty "c2100 identity1" prop_c2100_identity1] -p79_27_properties :: Test.Framework.Test +p79_27_properties :: TestTree p79_27_properties = - testGroup "p. 79, Section (2.7) Properties" [ + testGroup "p. 79, Section (2.7) properties" [ testProperty "c0102 identity1" prop_c0102_identity1, testProperty "c0201 identity1" prop_c0201_identity1, testProperty "c0300 identity2" prop_c0300_identity2, @@ -1159,9 +1173,9 @@ p79_27_properties = testProperty "c2100 identity2" prop_c2100_identity2 ] -p79_28_properties :: Test.Framework.Test +p79_28_properties :: TestTree p79_28_properties = - testGroup "p. 79, Section (2.8) Properties" [ + testGroup "p. 79, Section (2.8) properties" [ testProperty "c3000 identity" prop_c3000_identity, testProperty "c2010 identity" prop_c2010_identity, testProperty "c2001 identity" prop_c2001_identity, @@ -1170,9 +1184,9 @@ p79_28_properties = testProperty "c1011 identity" prop_c1011_identity ] -edge_incidence_tests :: Test.Framework.Test +edge_incidence_tests :: TestTree edge_incidence_tests = - testGroup "Edge Incidence Tests" [ + testGroup "Edge incidence tests" [ testProperty "t0 shares edge with t6" prop_t0_shares_edge_with_t6, testProperty "t0 shares edge with t1" prop_t0_shares_edge_with_t1, testProperty "t0 shares edge with t3" prop_t0_shares_edge_with_t3, @@ -1189,9 +1203,9 @@ edge_incidence_tests = testProperty "t6 shares edge with t7" prop_t6_shares_edge_with_t7, testProperty "t7 shares edge with t20" prop_t7_shares_edge_with_t20 ] -cube_properties :: Test.Framework.Test +cube_properties :: TestTree cube_properties = - testGroup "Cube Properties" [ + testGroup "Cube properties" [ p79_26_properties, p79_27_properties, p79_28_properties,