X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FGrid.hs;h=dc52482b0eb3cc2bc88656df24681759b8a4d346;hb=715be016934300f596a11e4fc5b8ca2ec42d6c34;hp=1a436acdc00d9276ceb1e25b7080355577822bf3;hpb=30bc407abc86ffa9a0eb4b26bdb4890f3ea423d1;p=spline3.git diff --git a/src/Grid.hs b/src/Grid.hs index 1a436ac..dc52482 100644 --- a/src/Grid.hs +++ b/src/Grid.hs @@ -1,14 +1,40 @@ +{-# LANGUAGE BangPatterns #-} -- | The Grid module just contains the Grid type and two constructors -- for it. We hide the main Grid constructor because we don't want -- to allow instantiation of a grid with h <= 0. -module Grid +module Grid ( + cube_at, + grid_tests, + make_grid, + slow_tests, + zoom + ) where -import Cube (Cube(Cube)) -import FunctionValues -import Misc (flatten) -import Point (Point) -import ThreeDimensional (contains_point) +import qualified Data.Array.Repa as R +import Test.HUnit (Assertion, assertEqual) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck ((==>), + Arbitrary(..), + Gen, + Positive(..), + Property, + choose) +import Assertions (assertAlmostEqual, assertTrue) +import Comparisons ((~=)) +import Cube (Cube(Cube), + find_containing_tetrahedron, + tetrahedra, + tetrahedron) +import Examples (trilinear, trilinear9x9x9, zeros, naturals_1d) +import FunctionValues (make_values, value_at) +import Point (Point(..)) +import ScaleFactor (ScaleFactor) +import Tetrahedron (Tetrahedron, c, polynomial, v0, v1, v2, v3) +import ThreeDimensional (ThreeDimensional(..)) +import Values (Values3D, dims, empty3d, zoom_shape) -- | Our problem is defined on a Grid. The grid size is given by the @@ -16,59 +42,471 @@ import ThreeDimensional (contains_point) -- function at the grid points, which are distance h from one -- another in each direction (x,y,z). data Grid = Grid { h :: Double, -- MUST BE GREATER THAN ZERO! - function_values :: [[[Double]]] } - deriving (Eq, Show) + function_values :: Values3D } + deriving (Show) + + +instance Arbitrary Grid where + arbitrary = do + (Positive h') <- arbitrary :: Gen (Positive Double) + fvs <- arbitrary :: Gen Values3D + return (make_grid h' fvs) -- | The constructor that we want people to use. If we're passed a -- non-positive grid size, we throw an error. -make_grid :: Double -> [[[Double]]] -> Grid +make_grid :: Double -> Values3D -> Grid make_grid grid_size values | grid_size <= 0 = error "grid size must be positive" | otherwise = Grid grid_size values --- | Creates an empty grid with grid size 1. -empty_grid :: Grid -empty_grid = Grid 1 [[[]]] + +-- | Takes a grid and a position as an argument and returns the cube +-- centered on that position. If there is no cube there (i.e. the +-- position is outside of the grid), it will throw an error. +cube_at :: Grid -> Int -> Int -> Int -> Cube +cube_at !g !i !j !k + | i < 0 = error "i < 0 in cube_at" + | i >= xsize = error "i >= xsize in cube_at" + | j < 0 = error "j < 0 in cube_at" + | j >= ysize = error "j >= ysize in cube_at" + | k < 0 = error "k < 0 in cube_at" + | k >= zsize = error "k >= zsize in cube_at" + | otherwise = Cube delta i j k fvs' tet_vol + where + fvs = function_values g + (xsize, ysize, zsize) = dims fvs + fvs' = make_values fvs i j k + delta = h g + tet_vol = (1/24)*(delta^(3::Int)) + +-- The first cube along any axis covers (-h/2, h/2). The second +-- covers (h/2, 3h/2). The third, (3h/2, 5h/2), and so on. +-- +-- We translate the (x,y,z) coordinates forward by 'h/2' so that the +-- first covers (0, h), the second covers (h, 2h), etc. This makes +-- it easy to figure out which cube contains the given point. +calculate_containing_cube_coordinate :: Grid -> Double -> Int +calculate_containing_cube_coordinate g coord + -- Don't use a cube on the boundary if we can help it. This + -- returns cube #1 if we would have returned cube #0 and cube #1 + -- exists. + | coord < offset = 0 + | coord == offset && (xsize > 1 && ysize > 1 && zsize > 1) = 1 + | otherwise = (ceiling ( (coord + offset) / cube_width )) - 1 + where + (xsize, ysize, zsize) = dims (function_values g) + cube_width = (h g) + offset = cube_width / 2 + + +-- | Takes a 'Grid', and returns a 'Cube' containing the given 'Point'. +-- Since our grid is rectangular, we can figure this out without having +-- to check every cube. +find_containing_cube :: Grid -> Point -> Cube +find_containing_cube g (Point x y z) = + cube_at g i j k + where + i = calculate_containing_cube_coordinate g x + j = calculate_containing_cube_coordinate g y + k = calculate_containing_cube_coordinate g z --- | Returns a three-dimensional list of cubes centered on the grid --- points of g with the appropriate 'FunctionValues'. -cubes :: Grid -> [[[Cube]]] -cubes g - | fvs == [[[]]] = [[[]]] - | head fvs == [[]] = [[[]]] +zoom_lookup :: Values3D -> ScaleFactor -> a -> (R.DIM3 -> Double) +zoom_lookup v3d scale_factor _ = + zoom_result v3d scale_factor + + +zoom_result :: Values3D -> ScaleFactor -> R.DIM3 -> Double +zoom_result v3d (sfx, sfy, sfz) (R.Z R.:. m R.:. n R.:. o) = + f p + where + g = make_grid 1 v3d + offset = (h g)/2 + m' = (fromIntegral m) / (fromIntegral sfx) - offset + n' = (fromIntegral n) / (fromIntegral sfy) - offset + o' = (fromIntegral o) / (fromIntegral sfz) - offset + p = Point m' n' o' + cube = find_containing_cube g p + t = find_containing_tetrahedron cube p + f = polynomial t + + +zoom :: Values3D -> ScaleFactor -> Values3D +zoom v3d scale_factor + | xsize == 0 || ysize == 0 || zsize == 0 = empty3d | otherwise = - [[[ Cube (h g) i j k (make_values fvs i j k) | i <- [0..xsize]] - | j <- [0..ysize]] - | k <- [0..zsize]] + R.compute $ R.unsafeTraverse v3d transExtent f + where + (xsize, ysize, zsize) = dims v3d + transExtent = zoom_shape scale_factor + f = zoom_lookup v3d scale_factor + + +-- | Check all coefficients of tetrahedron0 belonging to the cube +-- centered on (1,1,1) with a grid constructed from the trilinear +-- values. See example one in the paper. +-- +-- We also verify that the four vertices on face0 of the cube are +-- in the correct location. +-- +trilinear_c0_t0_tests :: Test.Framework.Test +trilinear_c0_t0_tests = + testGroup "trilinear c0 t0" + [testGroup "coefficients" + [testCase "c0030 is correct" test_trilinear_c0030, + testCase "c0003 is correct" test_trilinear_c0003, + testCase "c0021 is correct" test_trilinear_c0021, + testCase "c0012 is correct" test_trilinear_c0012, + testCase "c0120 is correct" test_trilinear_c0120, + testCase "c0102 is correct" test_trilinear_c0102, + testCase "c0111 is correct" test_trilinear_c0111, + testCase "c0210 is correct" test_trilinear_c0210, + testCase "c0201 is correct" test_trilinear_c0201, + testCase "c0300 is correct" test_trilinear_c0300, + testCase "c1020 is correct" test_trilinear_c1020, + testCase "c1002 is correct" test_trilinear_c1002, + testCase "c1011 is correct" test_trilinear_c1011, + testCase "c1110 is correct" test_trilinear_c1110, + testCase "c1101 is correct" test_trilinear_c1101, + testCase "c1200 is correct" test_trilinear_c1200, + testCase "c2010 is correct" test_trilinear_c2010, + testCase "c2001 is correct" test_trilinear_c2001, + testCase "c2100 is correct" test_trilinear_c2100, + testCase "c3000 is correct" test_trilinear_c3000], + + testGroup "face0 vertices" + [testCase "v0 is correct" test_trilinear_f0_t0_v0, + testCase "v1 is correct" test_trilinear_f0_t0_v1, + testCase "v2 is correct" test_trilinear_f0_t0_v2, + testCase "v3 is correct" test_trilinear_f0_t0_v3] + ] + where + g = make_grid 1 trilinear + cube = cube_at g 1 1 1 + t = tetrahedron cube 0 + + test_trilinear_c0030 :: Assertion + test_trilinear_c0030 = + assertAlmostEqual "c0030 is correct" (c t 0 0 3 0) (17/8) + + test_trilinear_c0003 :: Assertion + test_trilinear_c0003 = + assertAlmostEqual "c0003 is correct" (c t 0 0 0 3) (27/8) + + test_trilinear_c0021 :: Assertion + test_trilinear_c0021 = + assertAlmostEqual "c0021 is correct" (c t 0 0 2 1) (61/24) + + test_trilinear_c0012 :: Assertion + test_trilinear_c0012 = + assertAlmostEqual "c0012 is correct" (c t 0 0 1 2) (71/24) + + test_trilinear_c0120 :: Assertion + test_trilinear_c0120 = + assertAlmostEqual "c0120 is correct" (c t 0 1 2 0) (55/24) + + test_trilinear_c0102 :: Assertion + test_trilinear_c0102 = + assertAlmostEqual "c0102 is correct" (c t 0 1 0 2) (73/24) + + test_trilinear_c0111 :: Assertion + test_trilinear_c0111 = + assertAlmostEqual "c0111 is correct" (c t 0 1 1 1) (8/3) + + test_trilinear_c0210 :: Assertion + test_trilinear_c0210 = + assertAlmostEqual "c0210 is correct" (c t 0 2 1 0) (29/12) + + test_trilinear_c0201 :: Assertion + test_trilinear_c0201 = + assertAlmostEqual "c0201 is correct" (c t 0 2 0 1) (11/4) + + test_trilinear_c0300 :: Assertion + test_trilinear_c0300 = + assertAlmostEqual "c0300 is correct" (c t 0 3 0 0) (5/2) + + test_trilinear_c1020 :: Assertion + test_trilinear_c1020 = + assertAlmostEqual "c1020 is correct" (c t 1 0 2 0) (8/3) + + test_trilinear_c1002 :: Assertion + test_trilinear_c1002 = + assertAlmostEqual "c1002 is correct" (c t 1 0 0 2) (23/6) + + test_trilinear_c1011 :: Assertion + test_trilinear_c1011 = + assertAlmostEqual "c1011 is correct" (c t 1 0 1 1) (13/4) + + test_trilinear_c1110 :: Assertion + test_trilinear_c1110 = + assertAlmostEqual "c1110 is correct" (c t 1 1 1 0) (23/8) + + test_trilinear_c1101 :: Assertion + test_trilinear_c1101 = + assertAlmostEqual "c1101 is correct" (c t 1 1 0 1) (27/8) + + test_trilinear_c1200 :: Assertion + test_trilinear_c1200 = + assertAlmostEqual "c1200 is correct" (c t 1 2 0 0) 3 + + test_trilinear_c2010 :: Assertion + test_trilinear_c2010 = + assertAlmostEqual "c2010 is correct" (c t 2 0 1 0) (10/3) + + test_trilinear_c2001 :: Assertion + test_trilinear_c2001 = + assertAlmostEqual "c2001 is correct" (c t 2 0 0 1) 4 + + test_trilinear_c2100 :: Assertion + test_trilinear_c2100 = + assertAlmostEqual "c2100 is correct" (c t 2 1 0 0) (7/2) + + test_trilinear_c3000 :: Assertion + test_trilinear_c3000 = + assertAlmostEqual "c3000 is correct" (c t 3 0 0 0) 4 + + test_trilinear_f0_t0_v0 :: Assertion + test_trilinear_f0_t0_v0 = + assertEqual "v0 is correct" (v0 t) (Point 1 1 1) + + test_trilinear_f0_t0_v1 :: Assertion + test_trilinear_f0_t0_v1 = + assertEqual "v1 is correct" (v1 t) (Point 0.5 1 1) + + test_trilinear_f0_t0_v2 :: Assertion + test_trilinear_f0_t0_v2 = + assertEqual "v2 is correct" (v2 t) (Point 0.5 0.5 1.5) + + test_trilinear_f0_t0_v3 :: Assertion + test_trilinear_f0_t0_v3 = + assertEqual "v3 is correct" (v3 t) (Point 0.5 1.5 1.5) + + +test_trilinear_reproduced :: Assertion +test_trilinear_reproduced = + assertTrue "trilinears are reproduced correctly" $ + and [p (Point i' j' k') ~= value_at trilinear i j k + | i <- [0..2], + j <- [0..2], + k <- [0..2], + c0 <- cs, + t <- tetrahedra c0, + let p = polynomial t, + let i' = fromIntegral i, + let j' = fromIntegral j, + let k' = fromIntegral k] where - fvs = function_values g - zsize = (length fvs) - 1 - ysize = length (head fvs) - 1 - xsize = length (head $ head fvs) - 1 + g = make_grid 1 trilinear + cs = [ cube_at g ci cj ck | ci <- [0..2], cj <- [0..2], ck <- [0..2] ] --- | Takes a grid and a position as an argument and returns the cube --- centered on that position. If there is no cube there (i.e. the --- position is outside of the grid), it will return 'Nothing'. -cube_at :: Grid -> Int -> Int -> Int -> Maybe Cube -cube_at g i j k - | i < 0 = Nothing - | j < 0 = Nothing - | k < 0 = Nothing - | i >= length (cubes g) = Nothing - | j >= length ((cubes g) !! i) = Nothing - | k >= length (((cubes g) !! i) !! j) = Nothing - | otherwise = Just $ (((cubes g) !! i) !! j) !! k - - --- | Takes a 'Grid', and returns all 'Cube's belonging to it that --- contain the given 'Point'. -find_containing_cubes :: Grid -> Point -> [Cube] -find_containing_cubes g p = - filter contains_our_point all_cubes +test_zeros_reproduced :: Assertion +test_zeros_reproduced = + assertTrue "the zero function is reproduced correctly" $ + and [p (Point i' j' k') ~= value_at zeros i j k + | i <- [0..2], + j <- [0..2], + k <- [0..2], + let i' = fromIntegral i, + let j' = fromIntegral j, + let k' = fromIntegral k, + c0 <- cs, + t0 <- tetrahedra c0, + let p = polynomial t0 ] where - all_cubes = flatten $ cubes g - contains_our_point = flip contains_point p + g = make_grid 1 zeros + cs = [ cube_at g ci cj ck | ci <- [0..2], cj <- [0..2], ck <- [0..2] ] + + +-- | Make sure we can reproduce a 9x9x9 trilinear from the 3x3x3 one. +test_trilinear9x9x9_reproduced :: Assertion +test_trilinear9x9x9_reproduced = + assertTrue "trilinear 9x9x9 is reproduced correctly" $ + and [p (Point i' j' k') ~= value_at trilinear9x9x9 i j k + | i <- [0..8], + j <- [0..8], + k <- [0..8], + t <- tetrahedra c0, + let p = polynomial t, + let i' = (fromIntegral i) * 0.5, + let j' = (fromIntegral j) * 0.5, + let k' = (fromIntegral k) * 0.5] + where + g = make_grid 1 trilinear + c0 = cube_at g 1 1 1 + + +-- | The point 'p' in this test lies on the boundary of tetrahedra 12 and 15. +-- However, the 'contains_point' test fails due to some numerical innacuracy. +-- This bug should have been fixed by setting a positive tolerance level. +-- +-- Example from before the fix: +-- +-- b1 (tetrahedron c 20) (0, 17.5, 0.5) +-- -0.0 +-- +test_tetrahedra_collision_sensitivity :: Assertion +test_tetrahedra_collision_sensitivity = + assertTrue "tetrahedron collision tests isn't too sensitive" $ + contains_point t20 p + where + g = make_grid 1 naturals_1d + cube = cube_at g 0 18 0 + p = Point 0 17.5 0.5 + t20 = tetrahedron cube 20 + + +prop_cube_indices_never_go_out_of_bounds :: Grid -> Gen Bool +prop_cube_indices_never_go_out_of_bounds g = + do + let delta = Grid.h g + let coordmin = negate (delta/2) + + let (xsize, ysize, zsize) = dims $ function_values g + let xmax = delta*(fromIntegral xsize) - (delta/2) + let ymax = delta*(fromIntegral ysize) - (delta/2) + let zmax = delta*(fromIntegral zsize) - (delta/2) + + x <- choose (coordmin, xmax) + y <- choose (coordmin, ymax) + z <- choose (coordmin, zmax) + + let idx_x = calculate_containing_cube_coordinate g x + let idx_y = calculate_containing_cube_coordinate g y + let idx_z = calculate_containing_cube_coordinate g z + + return $ + idx_x >= 0 && + idx_x <= xsize - 1 && + idx_y >= 0 && + idx_y <= ysize - 1 && + idx_z >= 0 && + idx_z <= zsize - 1 + + +-- | Given in Sorokina and Zeilfelder, p. 80, (2.9). Note that the +-- third and fourth indices of c-t10 have been switched. This is +-- because we store the triangles oriented such that their volume is +-- positive. If T and T-tilde share \ and v0,v0-tilde point +-- in opposite directions, one of them has to have negative volume! +prop_c0120_identity :: Grid -> Property +prop_c0120_identity g = + and [xsize >= 3, ysize >= 3, zsize >= 3] ==> + c t0 0 1 2 0 ~= (c t0 1 0 2 0 + c t10 1 0 0 2) / 2 + where + fvs = function_values g + (xsize, ysize, zsize) = dims fvs + cube0 = cube_at g 1 1 1 + cube1 = cube_at g 0 1 1 + t0 = tetrahedron cube0 0 -- These two tetrahedra share a face. + t10 = tetrahedron cube1 10 + + +-- | Given in Sorokina and Zeilfelder, p. 80, (2.9). See +-- 'prop_c0120_identity'. +prop_c0111_identity :: Grid -> Property +prop_c0111_identity g = + and [xsize >= 3, ysize >= 3, zsize >= 3] ==> + c t0 0 1 1 1 ~= (c t0 1 0 1 1 + c t10 1 0 1 1) / 2 + where + fvs = function_values g + (xsize, ysize, zsize) = dims fvs + cube0 = cube_at g 1 1 1 + cube1 = cube_at g 0 1 1 + t0 = tetrahedron cube0 0 -- These two tetrahedra share a face. + t10 = tetrahedron cube1 10 + + +-- | Given in Sorokina and Zeilfelder, p. 80, (2.9). See +-- 'prop_c0120_identity'. +prop_c0201_identity :: Grid -> Property +prop_c0201_identity g = + and [xsize >= 3, ysize >= 3, zsize >= 3] ==> + c t0 0 2 0 1 ~= (c t0 1 1 0 1 + c t10 1 1 1 0) / 2 + where + fvs = function_values g + (xsize, ysize, zsize) = dims fvs + cube0 = cube_at g 1 1 1 + cube1 = cube_at g 0 1 1 + t0 = tetrahedron cube0 0 -- These two tetrahedra share a face. + t10 = tetrahedron cube1 10 + + +-- | Given in Sorokina and Zeilfelder, p. 80, (2.9). See +-- 'prop_c0120_identity'. +prop_c0102_identity :: Grid -> Property +prop_c0102_identity g = + and [xsize >= 3, ysize >= 3, zsize >= 3] ==> + c t0 0 1 0 2 ~= (c t0 1 0 0 2 + c t10 1 0 2 0) / 2 + where + fvs = function_values g + (xsize, ysize, zsize) = dims fvs + cube0 = cube_at g 1 1 1 + cube1 = cube_at g 0 1 1 + t0 = tetrahedron cube0 0 -- These two tetrahedra share a face. + t10 = tetrahedron cube1 10 + + +-- | Given in Sorokina and Zeilfelder, p. 80, (2.9). See +-- 'prop_c0120_identity'. +prop_c0210_identity :: Grid -> Property +prop_c0210_identity g = + and [xsize >= 3, ysize >= 3, zsize >= 3] ==> + c t0 0 2 1 0 ~= (c t0 1 1 1 0 + c t10 1 1 0 1) / 2 + where + fvs = function_values g + (xsize, ysize, zsize) = dims fvs + cube0 = cube_at g 1 1 1 + cube1 = cube_at g 0 1 1 + t0 = tetrahedron cube0 0 -- These two tetrahedra share a face. + t10 = tetrahedron cube1 10 + + +-- | Given in Sorokina and Zeilfelder, p. 80, (2.9). See +-- 'prop_c0120_identity'. +prop_c0300_identity :: Grid -> Property +prop_c0300_identity g = + and [xsize >= 3, ysize >= 3, zsize >= 3] ==> + c t0 0 3 0 0 ~= (c t0 1 2 0 0 + c t10 1 2 0 0) / 2 + where + fvs = function_values g + (xsize, ysize, zsize) = dims fvs + cube0 = cube_at g 1 1 1 + cube1 = cube_at g 0 1 1 + t0 = tetrahedron cube0 0 -- These two tetrahedra share a face. + t10 = tetrahedron cube1 10 + + +-- | All of the properties from Section (2.9), p. 80. These require a +-- grid since they refer to two adjacent cubes. +p80_29_properties :: Test.Framework.Test +p80_29_properties = + testGroup "p. 80, Section (2.9) Properties" [ + testProperty "c0120 identity" prop_c0120_identity, + testProperty "c0111 identity" prop_c0111_identity, + testProperty "c0201 identity" prop_c0201_identity, + testProperty "c0102 identity" prop_c0102_identity, + testProperty "c0210 identity" prop_c0210_identity, + testProperty "c0300 identity" prop_c0300_identity ] + + +grid_tests :: Test.Framework.Test +grid_tests = + testGroup "Grid Tests" [ + trilinear_c0_t0_tests, + p80_29_properties, + testCase "tetrahedra collision test isn't too sensitive" + test_tetrahedra_collision_sensitivity, + testProperty "cube indices within bounds" + prop_cube_indices_never_go_out_of_bounds ] + + +-- Do the slow tests last so we can stop paying attention. +slow_tests :: Test.Framework.Test +slow_tests = + testGroup "Slow Tests" [ + testCase "trilinear reproduced" test_trilinear_reproduced, + testCase "trilinear9x9x9 reproduced" test_trilinear9x9x9_reproduced, + testCase "zeros reproduced" test_zeros_reproduced ]