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