X-Git-Url: http://gitweb.michael.orlitzky.com/?p=spline3.git;a=blobdiff_plain;f=src%2FGrid.hs;h=269b37cec68d5c2f6211971dc1af32316b86c7ae;hp=eb0de04a08110a973e3a89cbc03dfeb813110f65;hb=fd3d394c27e3a90de8238b98bd112c4fe3468ee0;hpb=f1ea5f4014fdf8756fc6a70cf51052cdccbc4294

diff --git a/src/Grid.hs b/src/Grid.hs
index eb0de04..269b37c 100644
--- a/src/Grid.hs
+++ b/src/Grid.hs
@@ -1,17 +1,16 @@
 {-# 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.
+-- | The Grid module contains the Grid type, its tests, and the 'zoom'
+--   function used to build the interpolation.
 module Grid (
   cube_at,
   grid_tests,
-  make_grid,
   slow_tests,
   zoom
   )
 where
 
 import qualified Data.Array.Repa as R
+import qualified Data.Array.Repa.Operators.Traversal as R (unsafeTraverse)
 import Test.HUnit (Assertion, assertEqual)
 import Test.Framework (Test, testGroup)
 import Test.Framework.Providers.HUnit (testCase)
@@ -19,9 +18,9 @@ import Test.Framework.Providers.QuickCheck2 (testProperty)
 import Test.QuickCheck ((==>),
                         Arbitrary(..),
                         Gen,
-                        Positive(..),
                         Property,
-                        choose)
+                        choose,
+                        vectorOf)
 import Assertions (assertAlmostEqual, assertTrue)
 import Comparisons ((~=))
 import Cube (Cube(Cube),
@@ -41,26 +40,23 @@ import Values (Values3D, dims, empty3d, zoom_shape)
 
 
 -- | Our problem is defined on a Grid. The grid size is given by the
---   positive number h. The function values are the values of the
---   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 :: Values3D }
+--   positive number h, which we have defined to always be 1 for
+--   performance reasons (and simplicity). The function values are the
+--   values of the function at the grid points, which are distance h=1
+--   from one another in each direction (x,y,z).
+data Grid = Grid { 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.
---   Ignore non-positive grid sizes for performance.
-make_grid :: Double -> Values3D -> Grid
-make_grid grid_size values =
-  Grid grid_size values
+      x_dim <- choose (1, 27)
+      y_dim <- choose (1, 27)
+      z_dim <- choose (1, 27)
+      elements <- vectorOf (x_dim * y_dim * z_dim) (arbitrary :: Gen Double)
+      let new_shape = (R.Z R.:. x_dim R.:. y_dim R.:. z_dim)
+      let fvs = R.fromListUnboxed new_shape elements
+      return $ Grid fvs
 
 
 
@@ -70,19 +66,18 @@ make_grid grid_size values =
 --   does improve performance.
 cube_at :: Grid -> Int -> Int -> Int -> Cube
 cube_at !g !i !j !k =
-   Cube delta i j k fvs' tet_vol
+   Cube i j k fvs' tet_vol
    where
      fvs = function_values g
      fvs' = make_values fvs i j k
-     delta = h g
-     tet_vol = (1/24)*(delta^(3::Int))
+     tet_vol = 1/24
 
 
---   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.
+--   The first cube along any axis covers (-1/2, 1/2). The second
+--   covers (1/2, 3/2).  The third, (3/2, 5/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
+--   We translate the (x,y,z) coordinates forward by 1/2 so that the
+--   first covers (0, 1), the second covers (1, 2), 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
@@ -91,11 +86,10 @@ calculate_containing_cube_coordinate g coord
     -- exists.
     | coord < offset = 0
     | coord == offset && (xsize > 1 && ysize > 1 && zsize > 1) = 1
-    | otherwise = (ceiling ( (coord + offset) / cube_width )) - 1
+    | otherwise = (ceiling (coord + offset)) - 1
     where
       (xsize, ysize, zsize) = dims (function_values g)
-      cube_width = (h g)
-      offset = cube_width / 2
+      offset = 1/2
 
 
 -- | Takes a 'Grid', and returns a 'Cube' containing the given 'Point'.
@@ -119,8 +113,8 @@ 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
+    g = Grid v3d
+    offset = 1/2
     m' = (fromIntegral m) / (fromIntegral sfx) - offset
     n' = (fromIntegral n) / (fromIntegral sfy) - offset
     o' = (fromIntegral o) / (fromIntegral sfz) - offset
@@ -130,15 +124,19 @@ zoom_result v3d (sfx, sfy, sfz) (R.Z R.:. m R.:. n R.:. o) =
     f = polynomial t
 
 
-zoom :: Values3D -> ScaleFactor -> Values3D
+--
+-- Instead of IO, we could get away with a generic monad 'm'
+-- here. However, /we/ only call this function from within IO.
+--
+zoom :: Values3D -> ScaleFactor -> IO Values3D
 zoom v3d scale_factor
-    | xsize == 0 || ysize == 0 || zsize == 0 = empty3d
+    | xsize == 0 || ysize == 0 || zsize == 0 = return empty3d
     | otherwise =
-        R.compute $ R.unsafeTraverse v3d transExtent f
-          where
-            (xsize, ysize, zsize) = dims v3d
-            transExtent = zoom_shape scale_factor
-            f = zoom_lookup v3d scale_factor
+        R.computeUnboxedP $ 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
@@ -180,7 +178,7 @@ trilinear_c0_t0_tests =
        testCase "v3 is correct" test_trilinear_f0_t0_v3]
     ]
   where
-    g = make_grid 1 trilinear
+    g = Grid trilinear
     cube = cube_at g 1 1 1
     t = tetrahedron cube 0
 
@@ -295,7 +293,7 @@ test_trilinear_reproduced =
                       let j' = fromIntegral j,
                       let k' = fromIntegral k]
     where
-      g = make_grid 1 trilinear
+      g = Grid trilinear
       cs = [ cube_at g ci cj ck | ci <- [0..2], cj <- [0..2], ck <- [0..2] ]
 
 
@@ -313,7 +311,7 @@ test_zeros_reproduced =
                       t0 <- tetrahedra c0,
                       let p = polynomial t0 ]
     where
-      g = make_grid 1 zeros
+      g = Grid zeros
       cs = [ cube_at g ci cj ck | ci <- [0..2], cj <- [0..2], ck <- [0..2] ]
 
 
@@ -331,7 +329,7 @@ test_trilinear9x9x9_reproduced =
               let j' = (fromIntegral j) * 0.5,
               let k' = (fromIntegral k) * 0.5]
     where
-      g = make_grid 1 trilinear
+      g = Grid trilinear
       c0 = cube_at g 1 1 1
 
 
@@ -339,13 +337,12 @@ test_trilinear9x9x9_reproduced =
 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 coordmin = negate (1/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)
+    let xmax = (fromIntegral xsize) - (1/2)
+    let ymax = (fromIntegral ysize) - (1/2)
+    let zmax = (fromIntegral zsize) - (1/2)
 
     x <- choose (coordmin, xmax)
     y <- choose (coordmin, ymax)
@@ -371,7 +368,7 @@ prop_cube_indices_never_go_out_of_bounds g =
 --   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] ==>
+  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
@@ -386,7 +383,7 @@ prop_c0120_identity g =
 --   'prop_c0120_identity'.
 prop_c0111_identity :: Grid -> Property
 prop_c0111_identity g =
-  and [xsize >= 3, ysize >= 3, zsize >= 3] ==>
+  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
@@ -401,7 +398,7 @@ prop_c0111_identity g =
 --   'prop_c0120_identity'.
 prop_c0201_identity :: Grid -> Property
 prop_c0201_identity g =
-  and [xsize >= 3, ysize >= 3, zsize >= 3] ==>
+  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
@@ -416,7 +413,7 @@ prop_c0201_identity g =
 --   'prop_c0120_identity'.
 prop_c0102_identity :: Grid -> Property
 prop_c0102_identity g =
-  and [xsize >= 3, ysize >= 3, zsize >= 3] ==>
+  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
@@ -431,7 +428,7 @@ prop_c0102_identity g =
 --   'prop_c0120_identity'.
 prop_c0210_identity :: Grid -> Property
 prop_c0210_identity g =
-  and [xsize >= 3, ysize >= 3, zsize >= 3] ==>
+  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
@@ -446,7 +443,7 @@ prop_c0210_identity g =
 --   'prop_c0120_identity'.
 prop_c0300_identity :: Grid -> Property
 prop_c0300_identity g =
-  and [xsize >= 3, ysize >= 3, zsize >= 3] ==>
+  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