accelerate-examples-1.2.0.0: examples/fluid/src-acc/Config.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TemplateHaskell #-}
--
-- Configuration parameters
--
module Config where
import Type
import Data.Label
import Control.Monad
import Prelude as P
import Data.Array.Accelerate as A
import Data.Array.Accelerate.IO.Codec.BMP as A
import Data.Array.Accelerate.Data.Colour.RGBA as A
import Data.Array.Accelerate.Examples.Internal as A
data Initial a
= FromFile FilePath
| FromFunction (Backend -> Int -> Int -> a)
data Config = Config
{
-- simulation
_viscosity :: !Float
, _diffusion :: !Float
, _timestep :: !Float
, _inputDensity :: !Float
, _inputVelocity :: !Float
, _simulationSteps :: !Int
, _simulationWidth :: !Int
, _simulationHeight :: !Int
-- visualisation
, _displayScale :: !Int
, _displayFramerate :: !Int
, _initialDensity :: DensityField
, _initialVelocity :: VelocityField
-- extra options to specify initial conditions for command parsing
, _setupDensity :: Initial DensityField
, _setupVelocity :: Initial VelocityField
}
$(mkLabels [''Config])
defaults :: Config
defaults = Config
{ _viscosity = 0
, _diffusion = 0
, _timestep = 0.1
, _inputDensity = 50
, _inputVelocity = 20
, _simulationSteps = 40
, _simulationWidth = 100
, _simulationHeight = 100
, _displayScale = 5
, _displayFramerate = 25
, _initialDensity = error "initial density??"
, _initialVelocity = error "initial velocity??"
, _setupDensity = FromFunction makeField_empty
, _setupVelocity = FromFunction makeField_empty
}
-- | The set of available command-line options
--
options :: [OptDescr (Config -> Config)]
options =
-- Simulation options
[ Option [] ["viscosity"]
(ReqArg (parse viscosity) "FLOAT")
(describe viscosity "viscosity for velocity damping")
, Option [] ["diffusion"]
(ReqArg (parse diffusion) "FLOAT")
(describe diffusion "diffusion rate for mass dispersion")
, Option [] ["delta"]
(ReqArg (parse timestep) "FLOAT")
(describe timestep "simulation time between each frame")
, Option [] ["density"]
(ReqArg (parse inputDensity) "FLOAT")
(describe inputDensity "magnitude of user input density")
, Option [] ["velocity"]
(ReqArg (parse inputVelocity) "FLOAT")
(describe inputVelocity "magnitude of user input velocity")
, Option [] ["iterations"]
(ReqArg (parse simulationSteps) "INT")
(describe simulationSteps "number of iterations of the linear solver")
, Option [] ["width"]
(ReqArg (parse simulationWidth) "INT")
(describe simulationWidth "grid width of simulation")
, Option [] ["height"]
(ReqArg (parse simulationHeight) "INT")
(describe simulationHeight "grid height of simulation")
-- Display options
, Option [] ["scale"]
(ReqArg (parse displayScale) "INT")
(describe displayScale "feature size of visualisation")
, Option [] ["framerate"]
(ReqArg (parse displayFramerate) "INT")
(describe displayFramerate "frame rate for visualisation")
-- Initial conditions
, Option [] ["bmp-density"]
(ReqArg (set setupDensity . FromFile) "FILE.bmp")
"file for initial fluid density"
, Option [] ["bmp-velocity"]
(ReqArg (set setupVelocity . FromFile) "FILE.bmp")
"file for initial fluid velocity"
, Option [] ["init-checks"]
(NoArg init_checks)
"initial density field with zero velocity field"
, Option [] ["init-man"]
(NoArg init_man)
"initial density field with swirling velocity"
, Option [] ["init-elk"]
(NoArg init_elk)
"initial density field with swirling velocity"
]
where
parse f x = set f (read x)
describe f msg = msg P.++ " (" P.++ show (get f defaults) P.++ ")"
init_checks = set setupDensity (FromFunction makeDensity_checks)
. set setupVelocity (FromFunction makeField_empty)
init_man = set setupDensity (FromFunction makeDensity_checks)
. set setupVelocity (FromFunction makeVelocity_man)
init_elk = set setupDensity (FromFunction makeDensity_checks)
. set setupVelocity (FromFunction makeVelocity_elk)
header :: [String]
header =
[ "accelerate-fluid (c) [2011..2013] The Accelerate Team"
, ""
, "Usage: accelerate-fluid [OPTIONS]"
, ""
]
footer :: [String]
footer =
[ ""
, "Runtime usage:"
, " ESC quit"
, " click add density sources to the image"
, " shift-click add velocity sources"
, " r reset the image"
, " d toggle display of density field"
, " v toggle display of velocity field lines"
, ""
]
-- Initial conditions
-- ------------------
initialiseConfig :: (Config, Options, [String]) -> IO (Config, Options, [String])
initialiseConfig (conf, opts, rest) = do
let backend = get optBackend opts
width = get simulationWidth conf
height = get simulationHeight conf
dens <- case get setupDensity conf of
FromFile fn -> loadDensity_bmp backend fn width height
FromFunction f -> return (f backend width height)
velo <- case get setupVelocity conf of
FromFile fn -> loadVelocity_bmp backend fn width height
FromFunction f -> return (f backend width height)
let conf' = set initialDensity dens
. set initialVelocity velo
$ conf
return (conf', opts, rest)
makeField_empty :: FieldElt e => Backend -> Int -> Int -> Field e
makeField_empty backend width height
= run backend
$ A.fill (constant (Z:.height:.width)) zero
makeDensity_checks :: Backend -> Int -> Int -> DensityField
makeDensity_checks backend width height
= let width' = constant $ P.fromIntegral width
height' = constant $ P.fromIntegral height
yc = constant $ P.fromIntegral (height `div` 2)
xc = constant $ P.fromIntegral (width `div` 2)
checks ix
= let Z :. y :. x = unlift ix
x' = A.fromIntegral x
y' = A.fromIntegral y
tx = 10 * (x' - xc) / width'
ty = 10 * (y' - yc) / height'
xk1 = abs tx A.> 3*pi/2 ? (0 , cos tx)
yk1 = abs ty A.> 3*pi/2 ? (0 , cos ty)
d1 = xk1 * yk1
in
0 `A.max` d1
in
run backend $ A.generate (constant (Z:.height:.width)) checks
makeVelocity_man :: Backend -> Int -> Int -> VelocityField
makeVelocity_man backend width height
= let width' = constant $ P.fromIntegral width
height' = constant $ P.fromIntegral height
yc = constant $ P.fromIntegral (height `div` 2)
xc = constant $ P.fromIntegral (width `div` 2)
man ix
= let Z :. y :. x = unlift ix
x' = A.fromIntegral x
y' = A.fromIntegral y
xk2 = cos (19 * (x' - xc) / width')
yk2 = cos (17 * (y' - yc) / height')
d2 = xk2 * yk2 / 5
in
lift (constant 0, d2)
in
run backend $ A.generate (constant (Z:.height:.width)) man
makeVelocity_elk :: Backend -> Int -> Int -> VelocityField
makeVelocity_elk backend width height
= let width' = constant $ P.fromIntegral width
height' = constant $ P.fromIntegral height
yc = constant $ P.fromIntegral (height `div` 2)
xc = constant $ P.fromIntegral (width `div` 2)
elk ix
= let Z :. y :. x = unlift ix
x' = A.fromIntegral x
y' = A.fromIntegral y
tx = 12 * (x' - xc) / width'
ty = 12 * (y' - yc) / height'
xk2 = cos tx
yk2 = -cos ty
d2 = xk2 * yk2 / 5
in
lift (constant 0, d2)
in
run backend $ A.generate (constant (Z:.height:.width)) elk
loadDensity_bmp :: Backend -> FilePath -> Int -> Int -> IO DensityField
loadDensity_bmp backend filepath width height
= do arr <- either (error . show) id `fmap` readImageFromBMP filepath
let Z:.h:.w = arrayShape arr
when (w P./= width P.|| h P./= height)
$ error "accelerate-fluid: density-bmp does not match width x height"
return . run backend $ A.map (luminance . unpackRGBA) (use arr)
loadVelocity_bmp :: Backend -> FilePath -> Int -> Int -> IO VelocityField
loadVelocity_bmp backend filepath width height
= do arr <- either (error . show) id `fmap` readImageFromBMP filepath
let Z:.h:.w = arrayShape arr
when (w P./= width P.|| h P./= height)
$ error "accelerate-fluid: velocity-bmp does not match width x height"
let conv rgb =
let RGBA r g _ _ = unlift (unpackRGBA8 rgb) :: RGBA (Exp Word8)
r' = A.fromIntegral (-128 + A.fromIntegral r :: Exp Int)
g' = A.fromIntegral (-128 + A.fromIntegral g :: Exp Int)
in lift (r' * 0.0001, g' * 0.0001)
return . run backend $ A.map conv (use arr)