gloss-examples-1.7.5.1: raster/Fluid/src-repa/Args.hs
module Args
( parseArgs
, configDefault)
where
import Config
import Model
import Data.Array.Repa as R
import Data.Array.Repa.Algorithms.Pixel as R
import Data.Array.Repa.IO.BMP as R
import qualified Data.Vector.Unboxed as U
import Prelude as P
import System.Exit
import Data.Char
parseArgs :: [String] -> Config -> IO Config
parseArgs args config
| [] <- args
= return config
| "-batch" : rest <- args
= parseArgs rest
$ config { configBatchMode = True }
| "-frames" : path : rest <- args
= parseArgs rest
$ config { configFramesMode = Just path
, configBatchMode = True }
| "-max" : num : rest <- args
, all isDigit num
= parseArgs rest
$ config { configMaxSteps = read num }
| "-size" : width : height : rest <- args
, all isDigit width
, all isDigit height
, width' <- read width
, height' <- read height
= parseArgs rest
$ config { configModelSize = (width', height')
, configInitialDensity = makeDensField_empty width' height'
, configInitialVelocity = makeVeloField_empty width' height' }
| "-unstable" : rest <- args
= parseArgs rest
$ config { configUnstable = True }
| "-iters" : num : rest <- args
, all isDigit num
= parseArgs rest
$ config { configIters = read num }
| "-scale" : int : rest <- args
= parseArgs rest
$ config { configScale = (read int, read int) }
| "-rate" : int : rest <- args
= parseArgs rest
$ config { configRate = read int }
| "-delta" : float : rest <- args
= parseArgs rest
$ config { configDelta = read float }
| "-diff" : float : rest <- args
= parseArgs rest
$ config { configDiff = read float }
| "-diff-after" : int : rest <- args
, all isDigit int
= parseArgs rest
$ config { configDiffAfter = read int }
| "-visc" : float : rest <- args
= parseArgs rest
$ config { configVisc = read float }
| "-user-dens" : float : rest <- args
= parseArgs rest
$ config { configDensity = read float }
| "-user-velo" : float : rest <- args
= parseArgs rest
$ config { configVisc = read float }
-- Initial Confditions ----------------------------------------------------
| "-dens-bmp" : filePath : rest <- args
= do dens <- loadDensBMP filePath
let Z :. height :. width = extent dens
parseArgs rest
$ config { configInitialDensity = dens
, configModelSize = (width, height) }
| "-velo-bmp" : filePath : rest <- args
= do velo <- loadVeloBMP filePath
let Z :. height :. width = extent velo
parseArgs rest
$ config { configInitialVelocity = velo
, configModelSize = (width, height) }
| "-init-checks" : rest <- args
= do let (width, height) = configModelSize config
parseArgs rest
$ config { configInitialDensity = makeDensField_checks width height
, configInitialVelocity = makeVeloField_empty width height }
| "-init-man" : rest <- args
= do let (width, height) = configModelSize config
parseArgs rest
$ config { configInitialDensity = makeDensField_checks width height
, configInitialVelocity = makeVeloField_man width height }
| "-init-elk" : rest <- args
= do let (width, height) = configModelSize config
parseArgs rest
$ config { configInitialDensity = makeDensField_checks width height
, configInitialVelocity = makeVeloField_elk width height }
| otherwise
= do printUsage
exitWith ExitSuccess
printUsage :: IO ()
printUsage
= putStr
$ unlines
[ "gloss-fluid [flags]"
, " -batch Run a fixed number of steps instead of displaying in a window."
, " -frames <PATH.bmp> Dump all frames to .bmp files (implies -batch)"
, " -max <INT> Quit after this number of steps."
, " -size <INT> <INT> Size of simulation. (100)"
, " -unstable Use the unstable linear solver (False)"
, " -iters <INT> Iterations for the linear solver. (40)"
, " -scale <INT> Width of a cell in the window. (5)"
, " -rate <INT> Frame rate. (30)"
, " -delta <FLOAT> Length of time step. (0.1)"
, " -diff <FLOAT> Diffusion rate for the density. (0)"
, " -diff-after <INT> Trigger diffusion after this step. (0)"
, " -visc <FLOAT> Diffusion rate for the velocity. (0)"
, " -user-dens <FLOAT> Magnitude of user inserted density. (100)"
, " -user-velo <FLOAT> Magnitude of user inserted velocity. (20)"
, " -bmp-dens <FILE.bmp> File for initial fluid density."
, " -bmp-velo <FILE.bmp> File for initial fluid velocity."
, ""
, " Run this with +RTS -N -qa -qg to enable threads."
, "" ]
configDefault :: Config
configDefault
= let modelW = 100
modelH = 100
in Config
{ configRate = 30
, configMaxSteps = 0
, configBatchMode = False
, configFramesMode = Nothing
, configModelSize = (modelW, modelH)
, configScale = (5, 5)
, configUnstable = False
, configIters = 40
, configDelta = 0.1
, configDiff = 0
, configDiffAfter = 0
, configVisc = 0
, configDensity = 100
, configVelocity = (20, 20)
, configInitialDensity = makeDensField_empty modelW modelH
, configInitialVelocity = makeVeloField_empty modelW modelH }
-- | Load a density field from a BMP file.
loadDensBMP :: FilePath -> IO DensityField
loadDensBMP filePath
= do result <- readImageFromBMP filePath
let arr = case result of
Right arr' -> arr'
Left err -> error $ show err
density <- computeUnboxedP
$ R.map floatLuminanceOfRGB8 arr
return density
-- | Load velocity field from a BMP file.
loadVeloBMP :: FilePath -> IO VelocityField
loadVeloBMP filePath
= do result <- readImageFromBMP filePath
let arr = case result of
Right arr' -> arr'
Left err -> error $ show err
let {-# INLINE conv #-}
conv (r, g, _b)
= let r' = fromIntegral (-128 + fromIntegral r :: Int)
g' = fromIntegral (-128 + fromIntegral g :: Int)
in (r' * 0.0001, g' * 0.0001)
velocity <- computeUnboxedP $ R.map conv arr
return velocity
-------------------------------------------------------------------------------
makeDensField_empty :: Int -> Int -> Array U DIM2 Float
makeDensField_empty width height
= R.fromUnboxed (Z :. height :. width)
$ U.replicate (width * height) 0
makeDensField_checks :: Int -> Int -> DensityField
makeDensField_checks width height
= let height' = fromIntegral height
xc = fromIntegral (width `div` 2)
yc = fromIntegral (height `div` 2)
in R.fromListUnboxed (Z :. height :. width)
$ [ let x' = fromIntegral (x - 1)
y' = fromIntegral (y - 1)
tx = 10 * (x' - xc) / height'
ty = 10 * (y' - yc) / height'
xk1 = if abs tx > 3*pi/2 then 0 else cos tx
yk1 = if abs ty > 3*pi/2 then 0 else cos ty
d1 = xk1 * yk1
in if (d1 < 0) then 0 else d1
| y <- [1 .. height]
, x <- [1 .. width] ]
-------------------------------------------------------------------------------
makeVeloField_empty :: Int -> Int -> Array U DIM2 (Float, Float)
makeVeloField_empty width height
= R.fromUnboxed (Z :. height :. width)
$ U.replicate (width * height) (0, 0)
makeVeloField_man :: Int -> Int -> VelocityField
makeVeloField_man width height
= let height' = fromIntegral height
xc = fromIntegral (width `div` 2)
yc = fromIntegral (height `div` 2)
in R.fromListUnboxed (Z :. height :. width)
$ [ let x' = fromIntegral x
y' = fromIntegral y
xk2 = cos (19 * (x' - xc) / height')
yk2 = cos (17 * (y' - yc) / height')
d2 = xk2 * yk2 / 5
in (0, d2)
| y <- [0..height - 1]
, x <- [0..width - 1] ]
makeVeloField_elk :: Int -> Int -> VelocityField
makeVeloField_elk width height
= let height' = fromIntegral height
xc = fromIntegral (width `div` 2)
yc = fromIntegral (height `div` 2)
in R.fromListUnboxed (Z :. height :. width)
$ [ let x' = fromIntegral x
y' = fromIntegral y
tx = 12 * (x' - xc) / height'
ty = 12 * (y' - yc) / height'
xk2 = cos tx
yk2 = -cos ty
d2 = xk2 * yk2 / 5
in (0, d2)
| y <- [0 .. height - 1]
, x <- [0 .. width - 1] ]