src/Grid.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 -- | The Grid module just contains the Grid type and two constructors
   3 --   for it. We hide the main Grid constructor because we don't want
   4 --   to allow instantiation of a grid with h <= 0.
   5 module Grid (
   6   cube_at,
   7   grid_tests,
   8   make_grid,
   9   slow_tests,
  10   zoom
  11   )
  12 where
  13
  14 import qualified Data.Array.Repa as R
  15 import Test.HUnit (Assertion, assertEqual)
  16 import Test.Framework (Test, testGroup)
  17 import Test.Framework.Providers.HUnit (testCase)
  18 import Test.Framework.Providers.QuickCheck2 (testProperty)
  19 import Test.QuickCheck ((==>),
  20                         Arbitrary(..),
  21                         Gen,
  22                         Positive(..),
  23                         Property,
  24                         choose)
  25 import Assertions (assertAlmostEqual, assertTrue)
  26 import Comparisons ((~=))
  27 import Cube (Cube(Cube),
  28              find_containing_tetrahedron,
  29              tetrahedra,
  30              tetrahedron)
  31 import Examples (trilinear, trilinear9x9x9, zeros, naturals_1d)
  32 import FunctionValues (make_values, value_at)
  33 import Point (Point(..))
  34 import ScaleFactor (ScaleFactor)
  35 import Tetrahedron (Tetrahedron, c, polynomial, v0, v1, v2, v3)
  36 import ThreeDimensional (ThreeDimensional(..))
  37 import Values (Values3D, dims, empty3d, zoom_shape)
  38
  39
  40 -- | Our problem is defined on a Grid. The grid size is given by the
  41 --   positive number h. The function values are the values of the
  42 --   function at the grid points, which are distance h from one
  43 --   another in each direction (x,y,z).
  44 data Grid = Grid { h :: Double, -- MUST BE GREATER THAN ZERO!
  45                    function_values :: Values3D }
  46           deriving (Show)
  47
  48
  49 instance Arbitrary Grid where
  50     arbitrary = do
  51       (Positive h') <- arbitrary :: Gen (Positive Double)
  52       fvs <- arbitrary :: Gen Values3D
  53       return (make_grid h' fvs)
  54
  55
  56 -- | The constructor that we want people to use.
  57 --   Ignore non-positive grid sizes for performance.
  58 make_grid :: Double -> Values3D -> Grid
  59 make_grid grid_size values =
  60   Grid grid_size values
  61
  62
  63
  64 -- | Takes a grid and a position as an argument and returns the cube
  65 --   centered on that position. If there is no cube there, well, you
  66 --   shouldn't have done that. The omitted "otherwise" case actually
  67 --   does improve performance.
  68 cube_at :: Grid -> Int -> Int -> Int -> Cube
  69 cube_at !g !i !j !k =
  70    Cube delta i j k fvs' tet_vol
  71    where
  72      fvs = function_values g
  73      fvs' = make_values fvs i j k
  74      delta = h g
  75      tet_vol = (1/24)*(delta^(3::Int))
  76
  77
  78 --   The first cube along any axis covers (-h/2, h/2). The second
  79 --   covers (h/2, 3h/2).  The third, (3h/2, 5h/2), and so on.
  80 --
  81 --   We translate the (x,y,z) coordinates forward by 'h/2' so that the
  82 --   first covers (0, h), the second covers (h, 2h), etc. This makes
  83 --   it easy to figure out which cube contains the given point.
  84 calculate_containing_cube_coordinate :: Grid -> Double -> Int
  85 calculate_containing_cube_coordinate g coord
  86     -- Don't use a cube on the boundary if we can help it. This
  87     -- returns cube #1 if we would have returned cube #0 and cube #1
  88     -- exists.
  89     | coord < offset = 0
  90     | coord == offset && (xsize > 1 && ysize > 1 && zsize > 1) = 1
  91     | otherwise = (ceiling ( (coord + offset) / cube_width )) - 1
  92     where
  93       (xsize, ysize, zsize) = dims (function_values g)
  94       cube_width = (h g)
  95       offset = cube_width / 2
  96
  97
  98 -- | Takes a 'Grid', and returns a 'Cube' containing the given 'Point'.
  99 --   Since our grid is rectangular, we can figure this out without having
 100 --   to check every cube.
 101 find_containing_cube :: Grid -> Point -> Cube
 102 find_containing_cube g (Point x y z) =
 103     cube_at g i j k
 104     where
 105       i = calculate_containing_cube_coordinate g x
 106       j = calculate_containing_cube_coordinate g y
 107       k = calculate_containing_cube_coordinate g z
 108
 109
 110 zoom_lookup :: Values3D -> ScaleFactor -> a -> (R.DIM3 -> Double)
 111 zoom_lookup v3d scale_factor _ =
 112     zoom_result v3d scale_factor
 113
 114
 115 zoom_result :: Values3D -> ScaleFactor -> R.DIM3 -> Double
 116 zoom_result v3d (sfx, sfy, sfz) (R.Z R.:. m R.:. n R.:. o) =
 117   f p
 118   where
 119     g = make_grid 1 v3d
 120     offset = (h g)/2
 121     m' = (fromIntegral m) / (fromIntegral sfx) - offset
 122     n' = (fromIntegral n) / (fromIntegral sfy) - offset
 123     o' = (fromIntegral o) / (fromIntegral sfz) - offset
 124     p  = Point m' n' o'
 125     cube = find_containing_cube g p
 126     t = find_containing_tetrahedron cube p
 127     f = polynomial t
 128
 129
 130 zoom :: Values3D -> ScaleFactor -> Values3D
 131 zoom v3d scale_factor
 132     | xsize == 0 || ysize == 0 || zsize == 0 = empty3d
 133     | otherwise =
 134         R.compute $ R.unsafeTraverse v3d transExtent f
 135           where
 136             (xsize, ysize, zsize) = dims v3d
 137             transExtent = zoom_shape scale_factor
 138             f = zoom_lookup v3d scale_factor
 139
 140
 141 -- | Check all coefficients of tetrahedron0 belonging to the cube
 142 --   centered on (1,1,1) with a grid constructed from the trilinear
 143 --   values. See example one in the paper.
 144 --
 145 --   We also verify that the four vertices on face0 of the cube are
 146 --   in the correct location.
 147 --
 148 trilinear_c0_t0_tests :: Test.Framework.Test
 149 trilinear_c0_t0_tests =
 150   testGroup "trilinear c0 t0"
 151     [testGroup "coefficients"
 152       [testCase "c0030 is correct" test_trilinear_c0030,
 153        testCase "c0003 is correct" test_trilinear_c0003,
 154        testCase "c0021 is correct" test_trilinear_c0021,
 155        testCase "c0012 is correct" test_trilinear_c0012,
 156        testCase "c0120 is correct" test_trilinear_c0120,
 157        testCase "c0102 is correct" test_trilinear_c0102,
 158        testCase "c0111 is correct" test_trilinear_c0111,
 159        testCase "c0210 is correct" test_trilinear_c0210,
 160        testCase "c0201 is correct" test_trilinear_c0201,
 161        testCase "c0300 is correct" test_trilinear_c0300,
 162        testCase "c1020 is correct" test_trilinear_c1020,
 163        testCase "c1002 is correct" test_trilinear_c1002,
 164        testCase "c1011 is correct" test_trilinear_c1011,
 165        testCase "c1110 is correct" test_trilinear_c1110,
 166        testCase "c1101 is correct" test_trilinear_c1101,
 167        testCase "c1200 is correct" test_trilinear_c1200,
 168        testCase "c2010 is correct" test_trilinear_c2010,
 169        testCase "c2001 is correct" test_trilinear_c2001,
 170        testCase "c2100 is correct" test_trilinear_c2100,
 171        testCase "c3000 is correct" test_trilinear_c3000],
 172
 173     testGroup "face0 vertices"
 174       [testCase "v0 is correct" test_trilinear_f0_t0_v0,
 175        testCase "v1 is correct" test_trilinear_f0_t0_v1,
 176        testCase "v2 is correct" test_trilinear_f0_t0_v2,
 177        testCase "v3 is correct" test_trilinear_f0_t0_v3]
 178     ]
 179   where
 180     g = make_grid 1 trilinear
 181     cube = cube_at g 1 1 1
 182     t = tetrahedron cube 0
 183
 184     test_trilinear_c0030 :: Assertion
 185     test_trilinear_c0030 =
 186       assertAlmostEqual "c0030 is correct" (c t 0 0 3 0) (17/8)
 187
 188     test_trilinear_c0003 :: Assertion
 189     test_trilinear_c0003 =
 190       assertAlmostEqual "c0003 is correct" (c t 0 0 0 3) (27/8)
 191
 192     test_trilinear_c0021 :: Assertion
 193     test_trilinear_c0021 =
 194       assertAlmostEqual "c0021 is correct" (c t 0 0 2 1) (61/24)
 195
 196     test_trilinear_c0012 :: Assertion
 197     test_trilinear_c0012 =
 198       assertAlmostEqual "c0012 is correct" (c t 0 0 1 2) (71/24)
 199
 200     test_trilinear_c0120 :: Assertion
 201     test_trilinear_c0120 =
 202       assertAlmostEqual "c0120 is correct" (c t 0 1 2 0) (55/24)
 203
 204     test_trilinear_c0102 :: Assertion
 205     test_trilinear_c0102 =
 206       assertAlmostEqual "c0102 is correct" (c t 0 1 0 2) (73/24)
 207
 208     test_trilinear_c0111 :: Assertion
 209     test_trilinear_c0111 =
 210       assertAlmostEqual "c0111 is correct" (c t 0 1 1 1) (8/3)
 211
 212     test_trilinear_c0210 :: Assertion
 213     test_trilinear_c0210 =
 214       assertAlmostEqual "c0210 is correct" (c t 0 2 1 0) (29/12)
 215
 216     test_trilinear_c0201 :: Assertion
 217     test_trilinear_c0201 =
 218       assertAlmostEqual "c0201 is correct" (c t 0 2 0 1) (11/4)
 219
 220     test_trilinear_c0300 :: Assertion
 221     test_trilinear_c0300 =
 222       assertAlmostEqual "c0300 is correct" (c t 0 3 0 0) (5/2)
 223
 224     test_trilinear_c1020 :: Assertion
 225     test_trilinear_c1020 =
 226       assertAlmostEqual "c1020 is correct" (c t 1 0 2 0) (8/3)
 227
 228     test_trilinear_c1002 :: Assertion
 229     test_trilinear_c1002 =
 230       assertAlmostEqual "c1002 is correct" (c t 1 0 0 2) (23/6)
 231
 232     test_trilinear_c1011 :: Assertion
 233     test_trilinear_c1011 =
 234       assertAlmostEqual "c1011 is correct" (c t 1 0 1 1) (13/4)
 235
 236     test_trilinear_c1110 :: Assertion
 237     test_trilinear_c1110 =
 238       assertAlmostEqual "c1110 is correct" (c t 1 1 1 0) (23/8)
 239
 240     test_trilinear_c1101 :: Assertion
 241     test_trilinear_c1101 =
 242       assertAlmostEqual "c1101 is correct" (c t 1 1 0 1) (27/8)
 243
 244     test_trilinear_c1200 :: Assertion
 245     test_trilinear_c1200 =
 246       assertAlmostEqual "c1200 is correct" (c t 1 2 0 0) 3
 247
 248     test_trilinear_c2010 :: Assertion
 249     test_trilinear_c2010 =
 250       assertAlmostEqual "c2010 is correct" (c t 2 0 1 0) (10/3)
 251
 252     test_trilinear_c2001 :: Assertion
 253     test_trilinear_c2001 =
 254       assertAlmostEqual "c2001 is correct" (c t 2 0 0 1) 4
 255
 256     test_trilinear_c2100 :: Assertion
 257     test_trilinear_c2100 =
 258       assertAlmostEqual "c2100 is correct" (c t 2 1 0 0) (7/2)
 259
 260     test_trilinear_c3000 :: Assertion
 261     test_trilinear_c3000 =
 262       assertAlmostEqual "c3000 is correct" (c t 3 0 0 0) 4
 263
 264     test_trilinear_f0_t0_v0 :: Assertion
 265     test_trilinear_f0_t0_v0 =
 266       assertEqual "v0 is correct" (v0 t) (Point 1 1 1)
 267
 268     test_trilinear_f0_t0_v1 :: Assertion
 269     test_trilinear_f0_t0_v1 =
 270       assertEqual "v1 is correct" (v1 t) (Point 0.5 1 1)
 271
 272     test_trilinear_f0_t0_v2 :: Assertion
 273     test_trilinear_f0_t0_v2 =
 274       assertEqual "v2 is correct" (v2 t) (Point 0.5 0.5 1.5)
 275
 276     test_trilinear_f0_t0_v3 :: Assertion
 277     test_trilinear_f0_t0_v3 =
 278       assertEqual "v3 is correct" (v3 t) (Point 0.5 1.5 1.5)
 279
 280
 281 test_trilinear_reproduced :: Assertion
 282 test_trilinear_reproduced =
 283     assertTrue "trilinears are reproduced correctly" $
 284              and [p (Point i' j' k') ~= value_at trilinear i j k
 285                     | i <- [0..2],
 286                       j <- [0..2],
 287                       k <- [0..2],
 288                       c0 <- cs,
 289                       t <- tetrahedra c0,
 290                       let p = polynomial t,
 291                       let i' = fromIntegral i,
 292                       let j' = fromIntegral j,
 293                       let k' = fromIntegral k]
 294     where
 295       g = make_grid 1 trilinear
 296       cs = [ cube_at g ci cj ck | ci <- [0..2], cj <- [0..2], ck <- [0..2] ]
 297
 298
 299 test_zeros_reproduced :: Assertion
 300 test_zeros_reproduced =
 301     assertTrue "the zero function is reproduced correctly" $
 302              and [p (Point i' j' k') ~= value_at zeros i j k
 303                     | i <- [0..2],
 304                       j <- [0..2],
 305                       k <- [0..2],
 306                       let i' = fromIntegral i,
 307                       let j' = fromIntegral j,
 308                       let k' = fromIntegral k,
 309                       c0 <- cs,
 310                       t0 <- tetrahedra c0,
 311                       let p = polynomial t0 ]
 312     where
 313       g = make_grid 1 zeros
 314       cs = [ cube_at g ci cj ck | ci <- [0..2], cj <- [0..2], ck <- [0..2] ]
 315
 316
 317 -- | Make sure we can reproduce a 9x9x9 trilinear from the 3x3x3 one.
 318 test_trilinear9x9x9_reproduced :: Assertion
 319 test_trilinear9x9x9_reproduced =
 320     assertTrue "trilinear 9x9x9 is reproduced correctly" $
 321       and [p (Point i' j' k') ~= value_at trilinear9x9x9 i j k
 322             | i <- [0..8],
 323               j <- [0..8],
 324               k <- [0..8],
 325               t <- tetrahedra c0,
 326               let p = polynomial t,
 327               let i' = (fromIntegral i) * 0.5,
 328               let j' = (fromIntegral j) * 0.5,
 329               let k' = (fromIntegral k) * 0.5]
 330     where
 331       g = make_grid 1 trilinear
 332       c0 = cube_at g 1 1 1
 333
 334
 335 -- | The point 'p' in this test lies on the boundary of tetrahedra 12 and 15.
 336 --   However, the 'contains_point' test fails due to some numerical innacuracy.
 337 --   This bug should have been fixed by setting a positive tolerance level.
 338 --
 339 --   Example from before the fix:
 340 --
 341 --   b1 (tetrahedron c 20) (0, 17.5, 0.5)
 342 --   -0.0
 343 --
 344 test_tetrahedra_collision_sensitivity :: Assertion
 345 test_tetrahedra_collision_sensitivity =
 346   assertTrue "tetrahedron collision tests isn't too sensitive" $
 347              contains_point t20 p
 348   where
 349     g = make_grid 1 naturals_1d
 350     cube = cube_at g 0 18 0
 351     p = Point 0 17.5 0.5
 352     t20 = tetrahedron cube 20
 353
 354
 355 prop_cube_indices_never_go_out_of_bounds :: Grid -> Gen Bool
 356 prop_cube_indices_never_go_out_of_bounds g =
 357   do
 358     let delta = Grid.h g
 359     let coordmin = negate (delta/2)
 360
 361     let (xsize, ysize, zsize) = dims $ function_values g
 362     let xmax = delta*(fromIntegral xsize) - (delta/2)
 363     let ymax = delta*(fromIntegral ysize) - (delta/2)
 364     let zmax = delta*(fromIntegral zsize) - (delta/2)
 365
 366     x <- choose (coordmin, xmax)
 367     y <- choose (coordmin, ymax)
 368     z <- choose (coordmin, zmax)
 369
 370     let idx_x = calculate_containing_cube_coordinate g x
 371     let idx_y = calculate_containing_cube_coordinate g y
 372     let idx_z = calculate_containing_cube_coordinate g z
 373
 374     return $
 375       idx_x >= 0 &&
 376       idx_x <= xsize - 1 &&
 377       idx_y >= 0 &&
 378       idx_y <= ysize - 1 &&
 379       idx_z >= 0 &&
 380       idx_z <= zsize - 1
 381
 382
 383 -- | Given in Sorokina and Zeilfelder, p. 80, (2.9). Note that the
 384 --   third and fourth indices of c-t10 have been switched. This is
 385 --   because we store the triangles oriented such that their volume is
 386 --   positive. If T and T-tilde share \<v1,v2,v3\> and v0,v0-tilde point
 387 --   in opposite directions, one of them has to have negative volume!
 388 prop_c0120_identity :: Grid -> Property
 389 prop_c0120_identity g =
 390   and [xsize >= 3, ysize >= 3, zsize >= 3] ==>
 391     c t0 0 1 2 0 ~= (c t0 1 0 2 0 + c t10 1 0 0 2) / 2
 392   where
 393     fvs = function_values g
 394     (xsize, ysize, zsize) = dims fvs
 395     cube0 = cube_at g 1 1 1
 396     cube1 = cube_at g 0 1 1
 397     t0 = tetrahedron cube0 0 -- These two tetrahedra share a face.
 398     t10 = tetrahedron cube1 10
 399
 400
 401 -- | Given in Sorokina and Zeilfelder, p. 80, (2.9). See
 402 --   'prop_c0120_identity'.
 403 prop_c0111_identity :: Grid -> Property
 404 prop_c0111_identity g =
 405   and [xsize >= 3, ysize >= 3, zsize >= 3] ==>
 406     c t0 0 1 1 1 ~= (c t0 1 0 1 1 + c t10 1 0 1 1) / 2
 407   where
 408     fvs = function_values g
 409     (xsize, ysize, zsize) = dims fvs
 410     cube0 = cube_at g 1 1 1
 411     cube1 = cube_at g 0 1 1
 412     t0 = tetrahedron cube0 0 -- These two tetrahedra share a face.
 413     t10 = tetrahedron cube1 10
 414
 415
 416 -- | Given in Sorokina and Zeilfelder, p. 80, (2.9). See
 417 --   'prop_c0120_identity'.
 418 prop_c0201_identity :: Grid -> Property
 419 prop_c0201_identity g =
 420   and [xsize >= 3, ysize >= 3, zsize >= 3] ==>
 421     c t0 0 2 0 1 ~= (c t0 1 1 0 1 + c t10 1 1 1 0) / 2
 422   where
 423     fvs = function_values g
 424     (xsize, ysize, zsize) = dims fvs
 425     cube0 = cube_at g 1 1 1
 426     cube1 = cube_at g 0 1 1
 427     t0 = tetrahedron cube0 0 -- These two tetrahedra share a face.
 428     t10 = tetrahedron cube1 10
 429
 430
 431 -- | Given in Sorokina and Zeilfelder, p. 80, (2.9). See
 432 --   'prop_c0120_identity'.
 433 prop_c0102_identity :: Grid -> Property
 434 prop_c0102_identity g =
 435   and [xsize >= 3, ysize >= 3, zsize >= 3] ==>
 436     c t0 0 1 0 2 ~= (c t0 1 0 0 2 + c t10 1 0 2 0) / 2
 437   where
 438     fvs = function_values g
 439     (xsize, ysize, zsize) = dims fvs
 440     cube0 = cube_at g 1 1 1
 441     cube1 = cube_at g 0 1 1
 442     t0 = tetrahedron cube0 0 -- These two tetrahedra share a face.
 443     t10 = tetrahedron cube1 10
 444
 445
 446 -- | Given in Sorokina and Zeilfelder, p. 80, (2.9). See
 447 --   'prop_c0120_identity'.
 448 prop_c0210_identity :: Grid -> Property
 449 prop_c0210_identity g =
 450   and [xsize >= 3, ysize >= 3, zsize >= 3] ==>
 451     c t0 0 2 1 0 ~= (c t0 1 1 1 0 + c t10 1 1 0 1) / 2
 452   where
 453     fvs = function_values g
 454     (xsize, ysize, zsize) = dims fvs
 455     cube0 = cube_at g 1 1 1
 456     cube1 = cube_at g 0 1 1
 457     t0 = tetrahedron cube0 0 -- These two tetrahedra share a face.
 458     t10 = tetrahedron cube1 10
 459
 460
 461 -- | Given in Sorokina and Zeilfelder, p. 80, (2.9). See
 462 --   'prop_c0120_identity'.
 463 prop_c0300_identity :: Grid -> Property
 464 prop_c0300_identity g =
 465   and [xsize >= 3, ysize >= 3, zsize >= 3] ==>
 466     c t0 0 3 0 0 ~= (c t0 1 2 0 0 + c t10 1 2 0 0) / 2
 467   where
 468     fvs = function_values g
 469     (xsize, ysize, zsize) = dims fvs
 470     cube0 = cube_at g 1 1 1
 471     cube1 = cube_at g 0 1 1
 472     t0 = tetrahedron cube0 0 -- These two tetrahedra share a face.
 473     t10 = tetrahedron cube1 10
 474
 475
 476 -- | All of the properties from Section (2.9), p. 80. These require a
 477 --   grid since they refer to two adjacent cubes.
 478 p80_29_properties :: Test.Framework.Test
 479 p80_29_properties =
 480   testGroup "p. 80, Section (2.9) Properties" [
 481     testProperty "c0120 identity" prop_c0120_identity,
 482     testProperty "c0111 identity" prop_c0111_identity,
 483     testProperty "c0201 identity" prop_c0201_identity,
 484     testProperty "c0102 identity" prop_c0102_identity,
 485     testProperty "c0210 identity" prop_c0210_identity,
 486     testProperty "c0300 identity" prop_c0300_identity ]
 487
 488
 489 grid_tests :: Test.Framework.Test
 490 grid_tests =
 491     testGroup "Grid Tests" [
 492       trilinear_c0_t0_tests,
 493       p80_29_properties,
 494       testCase "tetrahedra collision test isn't too sensitive"
 495         test_tetrahedra_collision_sensitivity,
 496       testProperty "cube indices within bounds"
 497         prop_cube_indices_never_go_out_of_bounds ]
 498
 499
 500 -- Do the slow tests last so we can stop paying attention.
 501 slow_tests :: Test.Framework.Test
 502 slow_tests =
 503     testGroup "Slow Tests" [
 504       testCase "trilinear reproduced" test_trilinear_reproduced,
 505       testCase "trilinear9x9x9 reproduced" test_trilinear9x9x9_reproduced,
 506       testCase "zeros reproduced" test_zeros_reproduced ]