src/FunctionValues.hs

   1 -- | The FunctionValues module contains the 'FunctionValues' type and
   2 --   the functions used to manipulate it.
   3 module FunctionValues (
   4   FunctionValues,
   5   empty_values,
   6   eval,
   7   make_values,
   8   rotate,
   9   function_values_tests,
  10   value_at
  11   )
  12 where
  13
  14 import Prelude hiding (LT)
  15 import Test.HUnit
  16 import Test.Framework (Test, testGroup)
  17 import Test.Framework.Providers.HUnit (testCase)
  18 import Test.QuickCheck (Arbitrary(..), choose)
  19
  20 import Assertions (assertTrue)
  21 import Cardinal ( Cardinal(..) )
  22 import Examples (trilinear)
  23 import Values (Values3D, dims, idx)
  24
  25 -- | The FunctionValues type represents the value of our function f at
  26 --   the 27 points surrounding (and including) the center of a
  27 --   cube. Each value of f can be accessed by the name of its
  28 --   direction.
  29 data FunctionValues =
  30     FunctionValues { front  :: Double,
  31                      back   :: Double,
  32                      left   :: Double,
  33                      right  :: Double,
  34                      top    :: Double,
  35                      down   :: Double,
  36                      front_left :: Double,
  37                      front_right :: Double,
  38                      front_down :: Double,
  39                      front_top :: Double,
  40                      back_left :: Double,
  41                      back_right :: Double,
  42                      back_down :: Double,
  43                      back_top :: Double,
  44                      left_down :: Double,
  45                      left_top :: Double,
  46                      right_down :: Double,
  47                      right_top :: Double,
  48                      front_left_down :: Double,
  49                      front_left_top :: Double,
  50                      front_right_down :: Double,
  51                      front_right_top :: Double,
  52                      back_left_down :: Double,
  53                      back_left_top :: Double,
  54                      back_right_down :: Double,
  55                      back_right_top :: Double,
  56                      interior :: Double }
  57       deriving (Eq, Show)
  58
  59
  60 instance Arbitrary FunctionValues where
  61     arbitrary = do
  62       front'  <- choose (min_double, max_double)
  63       back'   <- choose (min_double, max_double)
  64       left'   <- choose (min_double, max_double)
  65       right'  <- choose (min_double, max_double)
  66       top'    <- choose (min_double, max_double)
  67       down'   <- choose (min_double, max_double)
  68       front_left' <- choose (min_double, max_double)
  69       front_right' <- choose (min_double, max_double)
  70       front_top' <- choose (min_double, max_double)
  71       front_down' <- choose (min_double, max_double)
  72       back_left' <- choose (min_double, max_double)
  73       back_right' <- choose (min_double, max_double)
  74       back_top' <- choose (min_double, max_double)
  75       back_down' <- choose (min_double, max_double)
  76       left_top' <- choose (min_double, max_double)
  77       left_down' <- choose (min_double, max_double)
  78       right_top' <- choose (min_double, max_double)
  79       right_down' <- choose (min_double, max_double)
  80       front_left_top' <- choose (min_double, max_double)
  81       front_left_down' <- choose (min_double, max_double)
  82       front_right_top' <- choose (min_double, max_double)
  83       front_right_down' <- choose (min_double, max_double)
  84       back_left_top' <- choose (min_double, max_double)
  85       back_left_down' <- choose (min_double, max_double)
  86       back_right_top' <- choose (min_double, max_double)
  87       back_right_down' <- choose (min_double, max_double)
  88       interior' <- choose (min_double, max_double)
  89
  90       return empty_values { front = front',
  91                             back  = back',
  92                             left  = left',
  93                             right = right',
  94                             top   = top',
  95                             down  = down',
  96                             front_left = front_left',
  97                             front_right = front_right',
  98                             front_top = front_top',
  99                             front_down = front_down',
 100                             back_left = back_left',
 101                             back_right = back_right',
 102                             back_top = back_top',
 103                             back_down = back_down',
 104                             left_top = left_top',
 105                             left_down = left_down',
 106                             right_top = right_top',
 107                             right_down = right_down',
 108                             front_left_top = front_left_top',
 109                             front_left_down = front_left_down',
 110                             front_right_top = front_right_top',
 111                             front_right_down = front_right_down',
 112                             back_left_top = back_left_top',
 113                             back_left_down = back_left_down',
 114                             back_right_top = back_right_top',
 115                             back_right_down = back_right_down',
 116                             interior = interior' }
 117       where
 118         -- | We perform addition with the function values contained in a
 119         --   FunctionValues object. If we choose random doubles near the machine
 120         --   min/max, we risk overflowing or underflowing the 'Double'. This
 121         --   places a reasonably safe limit on the maximum size of our generated
 122         --   'Double' members.
 123         max_double :: Double
 124         max_double = 10000.0
 125
 126         -- | See 'max_double'.
 127         min_double :: Double
 128         min_double = (-1) * max_double
 129
 130
 131 -- | Return a 'FunctionValues' with a bunch of zeros for data points.
 132 empty_values :: FunctionValues
 133 empty_values =
 134     FunctionValues 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
 135
 136 -- | The eval function is where the magic happens for the
 137 --   FunctionValues type. Given a 'Cardinal' direction and a
 138 --   'FunctionValues' object, eval will return the value of the
 139 --   function f in that 'Cardinal' direction. Note that 'Cardinal' can
 140 --   be a composite type; eval is what performs the \"arithmetic\" on
 141 --   'Cardinal' directions.
 142 eval :: FunctionValues -> Cardinal -> Double
 143 eval f F = front f
 144 eval f B = back f
 145 eval f L = left f
 146 eval f R = right f
 147 eval f T = top f
 148 eval f D = down f
 149 eval f FL = front_left f
 150 eval f FR = front_right f
 151 eval f FD = front_down f
 152 eval f FT = front_top f
 153 eval f BL = back_left f
 154 eval f BR = back_right f
 155 eval f BD = back_down f
 156 eval f BT = back_top f
 157 eval f LD = left_down f
 158 eval f LT = left_top f
 159 eval f RD = right_down f
 160 eval f RT = right_top f
 161 eval f FLD = front_left_down f
 162 eval f FLT = front_left_top f
 163 eval f FRD = front_right_down f
 164 eval f FRT = front_right_top f
 165 eval f BLD = back_left_down f
 166 eval f BLT = back_left_top f
 167 eval f BRD = back_right_down f
 168 eval f BRT = back_right_top f
 169 eval f I   = interior f
 170 eval _ (Scalar x) = x
 171 eval f (Sum x y) = (eval f x) + (eval f y)
 172 eval f (Difference x y) = (eval f x) - (eval f y)
 173 eval f (Product x y) = (eval f x) * (eval f y)
 174 eval f (Quotient x y) = (eval f x) / (eval f y)
 175
 176 -- | Takes a three-dimensional list of 'Double' and a set of 3D
 177 --   coordinates (i,j,k), and returns the value at (i,j,k) in the
 178 --   supplied list. If there is no such value, we choose a nearby
 179 --   point and use its value.
 180 --
 181 --   Examples:
 182 --
 183 --   >>> value_at Examples.trilinear 0 0 0
 184 --   1.0
 185 --
 186 --   >>> value_at Examples.trilinear (-1) 0 0
 187 --   1.0
 188 --
 189 --   >>> value_at Examples.trilinear 0 0 4
 190 --   1.0
 191 --
 192 --   >>> value_at Examples.trilinear 1 3 0
 193 --   4.0
 194 --
 195 value_at :: Values3D -> Int -> Int -> Int -> Double
 196 value_at v3d i j k
 197          | i < 0 = value_at v3d 0 j k
 198          | j < 0 = value_at v3d i 0 k
 199          | k < 0 = value_at v3d i j 0
 200          | xsize <= i = value_at v3d (xsize - 1) j k
 201          | ysize <= j = value_at v3d i (ysize - 1) k
 202          | zsize <= k = value_at v3d i j (zsize - 1)
 203          | otherwise = idx v3d i j k
 204   where
 205     (xsize, ysize, zsize) = dims v3d
 206
 207
 208 -- | Given a three-dimensional list of 'Double' and a set of 3D
 209 --   coordinates (i,j,k), constructs and returns the 'FunctionValues'
 210 --   object centered at (i,j,k)
 211 make_values :: Values3D -> Int -> Int -> Int -> FunctionValues
 212 make_values values i j k =
 213     empty_values { front  = value_at values (i-1) j k,
 214                    back   = value_at values (i+1) j k,
 215                    left   = value_at values i (j-1) k,
 216                    right  = value_at values i (j+1) k,
 217                    down   = value_at values i j (k-1),
 218                    top    = value_at values i j (k+1),
 219                    front_left = value_at values (i-1) (j-1) k,
 220                    front_right = value_at values (i-1) (j+1) k,
 221                    front_down =value_at values (i-1) j (k-1),
 222                    front_top = value_at values (i-1) j (k+1),
 223                    back_left = value_at values (i+1) (j-1) k,
 224                    back_right = value_at values (i+1) (j+1) k,
 225                    back_down = value_at values (i+1) j (k-1),
 226                    back_top = value_at values (i+1) j (k+1),
 227                    left_down = value_at values i (j-1) (k-1),
 228                    left_top = value_at values i (j-1) (k+1),
 229                    right_down = value_at values i (j+1) (k-1),
 230                    right_top = value_at values i (j+1) (k+1),
 231                    front_left_down = value_at values (i-1) (j-1) (k-1),
 232                    front_left_top = value_at values (i-1) (j-1) (k+1),
 233                    front_right_down = value_at values (i-1) (j+1) (k-1),
 234                    front_right_top = value_at values (i-1) (j+1) (k+1),
 235                    back_left_down = value_at values (i+1) (j-1) (k-1),
 236                    back_left_top = value_at values (i+1) (j-1) (k+1),
 237                    back_right_down = value_at values (i+1) (j+1) (k-1),
 238                    back_right_top = value_at values (i+1) (j+1) (k+1),
 239                    interior = value_at values i j k }
 240
 241 -- | Takes a 'FunctionValues' and a function that transforms one
 242 --   'Cardinal' to another (called a rotation). Then it applies the
 243 --   rotation to each element of the 'FunctionValues' object, and
 244 --   returns the result.
 245 rotate :: (Cardinal -> Cardinal) -> FunctionValues -> FunctionValues
 246 rotate rotation fv =
 247     FunctionValues { front  = eval fv (rotation F),
 248                      back   = eval fv (rotation B),
 249                      left   = eval fv (rotation L),
 250                      right  = eval fv (rotation R),
 251                      down   = eval fv (rotation D),
 252                      top    = eval fv (rotation T),
 253                      front_left = eval fv (rotation FL),
 254                      front_right = eval fv (rotation FR),
 255                      front_down = eval fv (rotation FD),
 256                      front_top = eval fv (rotation FT),
 257                      back_left = eval fv (rotation BL),
 258                      back_right = eval fv (rotation BR),
 259                      back_down = eval fv (rotation BD),
 260                      back_top = eval fv (rotation BT),
 261                      left_down = eval fv (rotation LD),
 262                      left_top = eval fv (rotation LT),
 263                      right_down = eval fv (rotation RD),
 264                      right_top = eval fv (rotation RT),
 265                      front_left_down = eval fv (rotation FLD),
 266                      front_left_top = eval fv (rotation FLT),
 267                      front_right_down = eval fv (rotation FRD),
 268                      front_right_top = eval fv (rotation FRT),
 269                      back_left_down = eval fv (rotation BLD),
 270                      back_left_top = eval fv (rotation BLT),
 271                      back_right_down = eval fv (rotation BRD),
 272                      back_right_top = eval fv (rotation BRT),
 273                      interior = interior fv }
 274
 275
 276
 277 -- | Ensure that the trilinear values wind up where we think they
 278 --   should.
 279 test_directions :: Assertion
 280 test_directions =
 281     assertTrue "all direction functions work" (and equalities)
 282         where
 283           fvs = make_values trilinear 1 1 1
 284           equalities = [ interior fvs == 4,
 285                          front fvs == 1,
 286                          back  fvs == 7,
 287                          left  fvs == 2,
 288                          right fvs == 6,
 289                          down  fvs == 3,
 290                          top   fvs == 5,
 291                          front_left fvs == 1,
 292                          front_right fvs == 1,
 293                          front_down fvs == 1,
 294                          front_top fvs == 1,
 295                          back_left fvs == 3,
 296                          back_right fvs == 11,
 297                          back_down fvs == 5,
 298                          back_top fvs == 9,
 299                          left_down fvs == 2,
 300                          left_top fvs == 2,
 301                          right_down fvs == 4,
 302                          right_top fvs == 8,
 303                          front_left_down fvs == 1,
 304                          front_left_top fvs == 1,
 305                          front_right_down fvs == 1,
 306                          front_right_top fvs == 1,
 307                          back_left_down fvs == 3,
 308                          back_left_top fvs == 3,
 309                          back_right_down fvs == 7,
 310                          back_right_top fvs == 15]
 311
 312
 313 function_values_tests :: Test.Framework.Test
 314 function_values_tests =
 315     testGroup "FunctionValues Tests"
 316                   [ testCase "test directions" test_directions ]