+-- The local "coefficient" function defined within the "c" function
+-- pattern matches on a bunch of integers, but doesn't handle the
+-- "otherwise" case for performance reasons.
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
{-# LANGUAGE BangPatterns #-}
+
module Tetrahedron (
Tetrahedron(..),
b0, -- Cube test
polynomial,
tetrahedron_properties,
tetrahedron_tests,
- volume -- Cube test
- )
+ volume ) -- Cube test
where
-import qualified Data.Vector as V (
- singleton,
- snoc,
- sum
- )
-
-import Test.Framework (Test, testGroup)
-import Test.Framework.Providers.HUnit (testCase)
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.HUnit (Assertion, assertEqual)
-import Test.QuickCheck (Arbitrary(..), Gen, Property, (==>))
-
-import Comparisons ((~=), nearly_ge)
-import FunctionValues (FunctionValues(..), empty_values)
-import Misc (factorial)
-import Point (Point(..), scale)
-import RealFunction (RealFunction, cmult, fexp)
+import Data.Vector ( singleton, snoc )
+import qualified Data.Vector as V ( sum )
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( Assertion, assertEqual, testCase )
+import Test.Tasty.QuickCheck (
+ Arbitrary( arbitrary ),
+ Gen,
+ Property,
+ (==>),
+ testProperty )
+
+import Comparisons ( (~=) )
+import FunctionValues (
+ FunctionValues( front, back, left, right, top, down, front_left,
+ front_right, front_down, front_top, back_left, back_right,
+ back_down, back_top, left_down, left_top, right_down,
+ right_top, front_left_down, front_left_top,
+ front_right_down, front_right_top, interior ),
+ empty_values )
+import Misc ( factorial )
+import Point ( Point(Point), scale )
+import RealFunction ( RealFunction, cmult, fexp )
data Tetrahedron =
Tetrahedron { function_values :: FunctionValues,
{-# INLINE polynomial #-}
polynomial :: Tetrahedron -> (RealFunction Point)
polynomial t =
- V.sum $ V.singleton ((c t 0 0 0 3) `cmult` (beta t 0 0 0 3)) `V.snoc`
- ((c t 0 0 1 2) `cmult` (beta t 0 0 1 2)) `V.snoc`
- ((c t 0 0 2 1) `cmult` (beta t 0 0 2 1)) `V.snoc`
- ((c t 0 0 3 0) `cmult` (beta t 0 0 3 0)) `V.snoc`
- ((c t 0 1 0 2) `cmult` (beta t 0 1 0 2)) `V.snoc`
- ((c t 0 1 1 1) `cmult` (beta t 0 1 1 1)) `V.snoc`
- ((c t 0 1 2 0) `cmult` (beta t 0 1 2 0)) `V.snoc`
- ((c t 0 2 0 1) `cmult` (beta t 0 2 0 1)) `V.snoc`
- ((c t 0 2 1 0) `cmult` (beta t 0 2 1 0)) `V.snoc`
- ((c t 0 3 0 0) `cmult` (beta t 0 3 0 0)) `V.snoc`
- ((c t 1 0 0 2) `cmult` (beta t 1 0 0 2)) `V.snoc`
- ((c t 1 0 1 1) `cmult` (beta t 1 0 1 1)) `V.snoc`
- ((c t 1 0 2 0) `cmult` (beta t 1 0 2 0)) `V.snoc`
- ((c t 1 1 0 1) `cmult` (beta t 1 1 0 1)) `V.snoc`
- ((c t 1 1 1 0) `cmult` (beta t 1 1 1 0)) `V.snoc`
- ((c t 1 2 0 0) `cmult` (beta t 1 2 0 0)) `V.snoc`
- ((c t 2 0 0 1) `cmult` (beta t 2 0 0 1)) `V.snoc`
- ((c t 2 0 1 0) `cmult` (beta t 2 0 1 0)) `V.snoc`
- ((c t 2 1 0 0) `cmult` (beta t 2 1 0 0)) `V.snoc`
+ V.sum $ singleton ((c t 0 0 0 3) `cmult` (beta t 0 0 0 3)) `snoc`
+ ((c t 0 0 1 2) `cmult` (beta t 0 0 1 2)) `snoc`
+ ((c t 0 0 2 1) `cmult` (beta t 0 0 2 1)) `snoc`
+ ((c t 0 0 3 0) `cmult` (beta t 0 0 3 0)) `snoc`
+ ((c t 0 1 0 2) `cmult` (beta t 0 1 0 2)) `snoc`
+ ((c t 0 1 1 1) `cmult` (beta t 0 1 1 1)) `snoc`
+ ((c t 0 1 2 0) `cmult` (beta t 0 1 2 0)) `snoc`
+ ((c t 0 2 0 1) `cmult` (beta t 0 2 0 1)) `snoc`
+ ((c t 0 2 1 0) `cmult` (beta t 0 2 1 0)) `snoc`
+ ((c t 0 3 0 0) `cmult` (beta t 0 3 0 0)) `snoc`
+ ((c t 1 0 0 2) `cmult` (beta t 1 0 0 2)) `snoc`
+ ((c t 1 0 1 1) `cmult` (beta t 1 0 1 1)) `snoc`
+ ((c t 1 0 2 0) `cmult` (beta t 1 0 2 0)) `snoc`
+ ((c t 1 1 0 1) `cmult` (beta t 1 1 0 1)) `snoc`
+ ((c t 1 1 1 0) `cmult` (beta t 1 1 1 0)) `snoc`
+ ((c t 1 2 0 0) `cmult` (beta t 1 2 0 0)) `snoc`
+ ((c t 2 0 0 1) `cmult` (beta t 2 0 0 1)) `snoc`
+ ((c t 2 0 1 0) `cmult` (beta t 2 0 1 0)) `snoc`
+ ((c t 2 1 0 0) `cmult` (beta t 2 1 0 0)) `snoc`
((c t 3 0 0 0) `cmult` (beta t 3 0 0 0))
coefficient `cmult` (b0_term * b1_term * b2_term * b3_term)
where
denominator = (factorial i)*(factorial j)*(factorial k)*(factorial l)
- coefficient = 6 / (fromIntegral denominator)
+ coefficient = (6 / (fromIntegral denominator)) :: Double
b0_term = (b0 t) `fexp` i
b1_term = (b1 t) `fexp` j
b2_term = (b2 t) `fexp` k
-- | Check the volume of a particular tetrahedron (computed by hand)
-- Its vertices are in clockwise order, so the volume should be
-- negative.
-tetrahedron1_geometry_tests :: Test.Framework.Test
+tetrahedron1_geometry_tests :: TestTree
tetrahedron1_geometry_tests =
testGroup "tetrahedron1 geometry"
[ testCase "volume1" volume1 ]
-- | Check the volume of a particular tetrahedron (computed by hand)
-- Its vertices are in counter-clockwise order, so the volume should
-- be positive.
-tetrahedron2_geometry_tests :: Test.Framework.Test
+tetrahedron2_geometry_tests :: TestTree
tetrahedron2_geometry_tests =
testGroup "tetrahedron2 geometry"
[ testCase "volume1" volume1 ]
-tetrahedron_tests :: Test.Framework.Test
+tetrahedron_tests :: TestTree
tetrahedron_tests =
- testGroup "Tetrahedron Tests" [
+ testGroup "Tetrahedron tests" [
tetrahedron1_geometry_tests,
tetrahedron2_geometry_tests ]
-p78_24_properties :: Test.Framework.Test
+p78_24_properties :: TestTree
p78_24_properties =
- testGroup "p. 78, Section (2.4) Properties" [
+ testGroup "p. 78, Section (2.4) properties" [
testProperty "c3000 identity" prop_c3000_identity,
testProperty "c2100 identity" prop_c2100_identity,
testProperty "c1110 identity" prop_c1110_identity]
-tetrahedron_properties :: Test.Framework.Test
+tetrahedron_properties :: TestTree
tetrahedron_properties =
- testGroup "Tetrahedron Properties" [
+ testGroup "Tetrahedron properties" [
p78_24_properties,
testProperty "b0_v0_always_unity" prop_b0_v0_always_unity,
testProperty "b0_v1_always_zero" prop_b0_v1_always_zero,
testProperty "b3_v0_always_zero" prop_b3_v0_always_zero,
testProperty "b3_v1_always_zero" prop_b3_v1_always_zero,
testProperty "b3_v2_always_zero" prop_b3_v2_always_zero,
- testProperty "swapping_vertices_doesnt_affect_coefficients1" $
+ testProperty "swapping_vertices_doesnt_affect_coefficients1"
prop_swapping_vertices_doesnt_affect_coefficients1,
- testProperty "swapping_vertices_doesnt_affect_coefficients2" $
+ testProperty "swapping_vertices_doesnt_affect_coefficients2"
prop_swapping_vertices_doesnt_affect_coefficients2,
- testProperty "swapping_vertices_doesnt_affect_coefficients3" $
+ testProperty "swapping_vertices_doesnt_affect_coefficients3"
prop_swapping_vertices_doesnt_affect_coefficients3,
- testProperty "swapping_vertices_doesnt_affect_coefficients4" $
+ testProperty "swapping_vertices_doesnt_affect_coefficients4"
prop_swapping_vertices_doesnt_affect_coefficients4 ]