src/Volumetric.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 -- | The Volumetric module contains functions for manipulating the
   3 --   volumetric data files found at,
   4 --
   5 --     <http://graphics.stanford.edu/data/voldata/>
   6 --
   7 module Volumetric (
   8   bracket_array,
   9   flip_x,
  10   flip_y,
  11   read_word16s,
  12   round_array,
  13   swap_bytes,
  14   write_values_to_bmp,
  15   write_word16s,
  16   z_slice
  17   )
  18 where
  19
  20 import Data.Word
  21 import Data.Bits
  22 import Data.Array.Repa                          as R
  23 import Data.Array.Repa.Eval                     as R (now)
  24 import Data.Array.Repa.Repr.Unboxed             as R
  25 import Data.Array.Repa.IO.Binary                as R
  26 import Data.Array.Repa.Algorithms.ColorRamp     as R
  27 import Data.Array.Repa.Operators.Traversal      as R (unsafeTraverse)
  28 import Data.Array.Repa.IO.BMP                   as R (writeImageToBMP)
  29
  30 import Values
  31
  32 -- | RawData is an array of words (16 bits), as contained in the
  33 --   volumetric data files.
  34 type RawData sh = Array U sh Word16
  35
  36 -- | A specialization of the 'RawData' type, to three dimensions.
  37 type RawData3D = RawData DIM3
  38
  39 type RGB = (Word8, Word8, Word8)
  40 type ColorData sh = Array U sh RGB
  41
  42
  43 {-# INLINE read_word16s #-}
  44 read_word16s :: FilePath -> DIM3 -> IO RawData3D
  45 read_word16s path shape = do
  46   arr <- R.readArrayFromStorableFile path shape
  47   c   <- R.copyP arr
  48   now $ c
  49
  50
  51
  52 bracket :: Double -> Double -> Double -> Word16
  53 bracket lower_threshold upper_threshold x
  54         | x < lower_threshold      = 0
  55         | x > upper_threshold      = 255
  56         | otherwise                    = truncate (r * 255)
  57             where
  58               numerator = x - lower_threshold
  59               denominator = upper_threshold - lower_threshold
  60               r = numerator/denominator
  61
  62
  63 flip16 :: Word16 -> Word16
  64 flip16 xx =
  65   shift xx 8 .|. (shift xx (-8) .&. 0x00ff)
  66
  67
  68 {-# INLINE swap_bytes #-}
  69 swap_bytes :: (Shape sh, Source r Word16) => Array r sh Word16
  70              -> Array D sh Word16
  71 swap_bytes =
  72   R.map flip16
  73
  74
  75 bracket_array :: Shape sh => Double -> Double -> Values sh -> Array D sh Word16
  76 bracket_array lt ut =
  77   R.map (bracket lt ut)
  78
  79
  80 {-# INLINE round_array #-}
  81 round_array :: Shape sh => Values sh -> Array D sh Word16
  82 round_array =
  83   R.map round
  84
  85
  86 flip_y :: Source r Word16 => Int -> Array r DIM3 Word16 -> Array D DIM3 Word16
  87 flip_y height arr =
  88   R.unsafeTraverse arr id
  89               (\get (Z :. z :. y :. x) ->
  90                    get (Z :. z :. (height - 1) - y :. x))
  91
  92 flip_x :: Source r Word16 => Int -> Array r DIM3 Word16 -> Array D DIM3 Word16
  93 flip_x width arr =
  94   R.unsafeTraverse arr id
  95               (\get (Z :. z :. y :. x) ->
  96                    get (Z :. z :. y :. (width - 1) - x))
  97
  98
  99 {-# INLINE write_word16s #-}
 100 write_word16s :: (Shape sh) => FilePath -> (RawData sh) -> IO ()
 101 write_word16s = R.writeArrayToStorableFile
 102
 103
 104
 105 --
 106 -- Instead of IO, we could get away with a generic monad 'm'
 107 -- here. However, /we/ only call this function from within IO.
 108 --
 109 values_to_colors :: (Shape sh) => (Values sh) -> IO (ColorData sh)
 110 values_to_colors arr =
 111   R.computeUnboxedP $ R.map (truncate_rgb . ramp_it) arr
 112   where
 113     ramp_it :: Double -> (Double, Double, Double)
 114     ramp_it x =
 115       if x == 0 then
 116         (0, 0, 0)
 117       else
 118         rampColorHotToCold 0 255 x
 119
 120     truncate_rgb :: (Double, Double, Double) -> (Word8, Word8, Word8)
 121     truncate_rgb (r, g, b) =
 122       (r', g', b')
 123       where
 124         r' = truncate (r * 255)
 125         g' = truncate (g * 255)
 126         b' = truncate (b * 255)
 127
 128
 129 write_values_to_bmp :: FilePath -> Values2D -> IO ()
 130 write_values_to_bmp path values = do
 131   colors <- values_to_colors values
 132   R.writeImageToBMP path colors
 133
 134
 135 z_slice :: (R.Unbox a, Source r a) => Int -> Array r DIM3 a -> Array D DIM2 a
 136 z_slice n arr =
 137   slice arr (Any :. n :. All :. All)