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