Sim.hs

   1 module Sim (
   2     Simulation, simSpace,
   3     ChunkType, ChunkData, chunkType,
   4     initSimSpace, testSim, physStep, validDirects,
   5     simToString
   6 ) where
   7
   8 import Debug.Trace
   9 import           Data.Vector ((!), (//))
  10 import qualified Data.Vector as V
  11
  12 data Simulation = Simulation
  13     { simSpace          :: V.Vector ChunkData
  14     , simW              :: Int
  15     , simH              :: Int
  16     } deriving (Show)
  17
  18 data ChunkType = Air
  19     | Water
  20     | Wall deriving (Show, Enum)
  21
  22 data ChunkData = ChunkData
  23     { chunkType         :: ChunkType
  24     } deriving (Show)
  25
  26 -- vec accessors
  27 simGet Simulation{simSpace=s,simW=w} x y = s ! (y*w+x)
  28 simSet sim@Simulation{simSpace=s,simW=w,simH=h} c x y = sim { simSpace = (s // [(y*w+x,c)]) }
  29 simGetChunkType sim x y = chunkType $ simGet sim x y
  30
  31 initSimSpace x y = Simulation
  32     { simSpace = V.replicate (y*x) ChunkData { chunkType=Air }
  33     , simW = x
  34     , simH = y
  35     }
  36
  37 testSim = let a = simSet (initSimSpace 10 10) (ChunkData Water) 5 5
  38           in simSet a (ChunkData Wall) 5 4
  39
  40 physStep sim@Simulation{simW=w,simH=h} = _physStep [(x, y) | x <- [0..w-1], y <- [0..h-1]] sim sim
  41 -- _physStep grid acc sim@Simulation{simSpace=s,simW=w,simH=h} | trace ("" ++ show h) False = undefined
  42 _physStep grid acc sim@Simulation{simSpace=s,simW=w,simH=h} =
  43     if null grid then acc
  44     else _physStep (tail grid) next sim
  45     where x = fst $ head grid
  46           y = snd $ head grid
  47           valid = validDirects x y w h
  48           next = case simGetChunkType sim x y of
  49               Water -> updateWaterChunk x y valid acc
  50               _ -> acc
  51
  52 -- takes in list of valid chunks, as well as the sim to modify
  53 -- updateWaterChunk x y valid sim | trace ("x:" ++ show x ++ " y:" ++ show y ++ " " ++ show valid) False = undefined
  54 updateWaterChunk x y valid sim =
  55     -- if the chunk below is free, fall straight down
  56     if elem (0,-1) valid && fromEnum (simGetChunkType sim x (y-1)) == fromEnum Air
  57         then
  58             let moved = simSet sim ChunkData { chunkType=Air } x y
  59             in simSet moved ChunkData { chunkType=Water } x (y-1)
  60     else if elem (-1,-1) valid && fromEnum (simGetChunkType sim (x-1) (y-1)) == fromEnum Air
  61         then
  62             let moved = simSet sim ChunkData { chunkType=Air } x y
  63             in simSet moved ChunkData { chunkType=Water } (x-1) (y-1)
  64     else if elem (1,-1) valid && fromEnum (simGetChunkType sim (x+1) (y-1)) == fromEnum Air
  65         then
  66             let moved = simSet sim ChunkData { chunkType=Air } x y
  67             in simSet moved ChunkData { chunkType=Water } (x+1) (y-1)
  68     -- stay put
  69     else sim
  70
  71 -- gets chunks around a given chunk that are inside grid
  72 -- validDirects x y w h | trace ("w:"++ show w ++ "h:" ++ show h) False = undefined
  73 validDirects x y w h = filter
  74     -- (\q -> 0 <= (fst q)+x && (fst q)+x < w && (snd q)+y <= 0 && (snd q)+y < h)
  75     (\q -> 0 <= (fst q)+x && (fst q)+x < w && 0 <= (snd q)+y && (snd q)+y < h)
  76     [(a,b) | a <- [-1..1], b <- [-1..1], not (a==0 && b==0)]
  77
  78 simToString :: Simulation -> [Char]
  79 simToString sim@Simulation{simW=w} =
  80     let simStr = V.toList $ V.map chunkToChar $ simSpace sim
  81     in insert w '\n' simStr
  82
  83 -- maps each chunktype to an ascii character
  84 chunkToChar :: ChunkData -> Char
  85 chunkToChar c =
  86     case chunkType c of
  87         Water -> '~'
  88         Air -> '.'
  89         Wall -> '#'
  90         _ -> '?'
  91
  92 -- from https://stackoverflow.com/questions/12659562/insert-specific-element-y-after-every-n-elements-in-a-list
  93 insert :: Int -> a -> [a] -> [a]
  94 insert n y xs = countdown n xs where
  95    countdown 0 xs = y:countdown n xs
  96    countdown _ [] = []
  97    countdown m (x:xs) = x:countdown (m-1) xs
  98