fffej

import qualified Data.Vector.Unboxed.Mutable as M
import qualified Data.Vector.Generic.Mutable as GM
import Control.Monad

type DVector = M.IOVector Double
data Grid = Grid Int DVector

-- |Create an empty vector
emptyGrid :: Int -> IO Grid
emptyGrid sz = do

fffej

-- |A simple loop over each pixel
forEachPixel :: Grid -> ((Int,Int) -> IO()) -> IO()
forEachPixel (Grid n _) = forM_ [(u,v) | u<-[1..n], v <- [1..n]]

-- |For simplicity, just consider up,down,left,right to be the neighbours
neighbours :: Grid -> (Int,Int) -> IO (Double,Double,Double,Double)
neighbours g (x,y) = do 
  up <- readVal g (x-1,y)
  down <- readVal g (x+1,y)
  left <- readVal g (x,y-1)

fffej

linSolveStep :: Int -> Grid -> Grid -> Double -> Double -> IO ()
linSolveStep b x x0 a c = forEachPixel x
                            (\(i,j) -> 
                             do
                               (up,down,left,right) <- neighbours x (i,j)
                               x0v <- readVal x0 (i,j)
                               writeVal x (i,j) ((x0v + a*(up + down + left + right)) / c))
                          >> setBnd b x

linSolve :: Int -> Grid -> Grid -> Double -> Double -> IO()

fffej

advect :: Int -> Grid -> Grid -> Grid -> Grid -> Double -> IO ()
advect b d@(Grid n _) d0 u v dt = forEachPixel d
                                   (\(i,j) ->
                                    do
                                      uVal <- readVal u (i,j)
                                      vVal <- readVal v (i,j)
                                      let n5 = fromIntegral n + 0.5
                                          x = min n5 (max 0.5 (fromIntegral i - dt0 * uVal))
                                          y = min n5 (max 0.5 (fromIntegral j - dt0 * vVal))
                                          i0 = truncate x

fffej

main = do
  x <- emptyGrid 80
  y <- emptyGrid 80
  u <- emptyGrid 80
  v <- emptyGrid 80
  defaultMain [
        bgroup "Mutable Fluids" [ 
                    bench "Project" $ nfIO (project x y u v)
                   ,bench "SetBnds" $ nfIO (setBnd 2 x)
                   ]]

fffej

data State = State {
      density :: Grid
    , previousDensity :: Grid
    , velocity :: (Grid,Grid)
    , previousVelocity :: (Grid,Grid)
    , mousePoint :: IORef (Int,Int)
    , oldMousePoint :: IORef (Int,Int)
    , leftDown :: IORef Bool
    , rightDown :: IORef Bool
    , drawVel :: IORef Bool

fffej

color3f :: Color3 GLfloat -> IO ()
color3f = color

vertex2f :: Vertex2 GLfloat -> IO ()
vertex2f = vertex :: Vertex2 GLfloat -> IO ()

colorVertex :: (Color3 GLfloat, Vertex2 GLfloat) -> IO ()  
colorVertex (c,v) = do
  color3f c
  vertex v

fffej

trun :: Double -> Double -> GLfloat
trun h i = realToFrac ((i-0.5) * h) :: GLfloat

drawVelocity :: (Grid,Grid) -> IO ()
drawVelocity (u,v) = do
  color3f (Color3 1 1 1)
  lineWidth $= 1.0
  let h = 1.0 / realToFrac n
  let f = trun h
  renderPrimitive Lines $ forM_ [(x,y) | x<-[1..n], y<-[1..n] ]

fffej

withinBounds :: (Double,Double) -> Bool
withinBounds (x,y) = (x**2+y**2) < 1.0

estimatePi :: [(Double,Double)] -> Double
estimatePi xs = 4.0 * within / len
    where
      len = fromIntegral $ length xs
      within = fromIntegral $ length $ filter withinBounds xs

fffej

data GameResult = Win | Lose | Draw
                  deriving (Show,Eq)

data Team = RSA | MEX | URA | FRA | 
            ARG | NGA | KOR | GRE | 
            ENG | USA | ALG | SVN | 
            GER | AUS | SRB | GHA | 
            NED | DEN | JPN | CMR | 
            ITA | PAR | NZL | SVK | 
            BRA | PRK | CIV | POR |