src/Grid.hs

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