lifter-0.1: src/Map.hs
module Map where
import Rules
import Data.Array.IO
import Control.Monad.State
import Data.Array.IO
import System.IO
import Debug.Trace
mkWorld :: Int -> Int -> [[Tile]] -> IO (IOArray (Int, Int) Tile)
mkWorld width height ts
= do arr <- newArray ((0,0), (width-1, height-1)) Empty
setArr arr 0 (reverse ts)
return arr
where setArr arr h (l : ls) = do setLine arr h 0 l
setArr arr (h+1) ls
setArr arr h [] = return ()
setLine arr h c (x : xs) = do writeArray arr (h,c) x
setLine arr h (c + 1) xs
setLine arr h c [] = return ()
parseMeta s l
= case words l of
["Growth", r] -> s { growthrate = read r }
["Razors", r] -> s { razors = read r }
["Water", r] -> s { waterlevel = read r }
["Waterproof", r] -> s { waterproofing = read r }
["Flooding", r] -> s { floodstep = read r, floodrate = read r }
["Trampoline", [x], "targets", [y]]
-> s { trampPath = updateMap y x (trampPath s) }
_ -> s
updateMap x y [] = []
updateMap x y ((k, v) : xs) | x == k = (x, v) : (y, v) : updateMap x y xs
| otherwise = (k, v) : updateMap x y xs
loadMap :: a -> FilePath -> Bool -> IO (GameState a)
loadMap extra f tr
= do fdata <- readFile f
let (tiles, metadata) = span (not.null) $ lines fdata
let (w, h) = (maximum (map length tiles), length tiles)
world <- newArray ((0,0), (w-1, h-1)) Empty
oldworld <- newArray ((0,0), (w-1, h-1)) Empty
let initSt = GS extra
(0,0) (0, 0) 0 0 0 0 0 0 growth [] [] False False False False
tr world 0 0 0 0 10 oldworld 0 2
let mSt = foldl parseMeta initSt metadata
mSt' <- execStateT (buildWorld w h tiles) mSt
-- HACK! Do it again to update trampoline metadata
return $ foldl parseMeta mSt' metadata
buildWorld :: Int -> Int -> [[Char]] -> StateT (GameState a) IO ()
buildWorld w h ts = setArr 0 (reverse (take h ts))
where setArr h (l : ls) = do setLine h 0 (take w l)
setArr (h + 1) ls
setArr h [] = return ()
setLine h c (x : xs) = do st <- get
st' <- lift $ setAt st h c x
put st'
setLine h (c + 1) xs
setLine h c [] = return ()
setAt st h c '#' = do writeArray (world st) (c,h) Wall
return st
setAt st h c 'R' = do writeArray (world st) (c,h) Player
return (st { playerpos = (c,h) })
setAt st h c 'L' = do writeArray (world st) (c,h) Exit
return (st { exitpos = (c,h) })
setAt st h c '.' = do writeArray (world st) (c,h) Dirt
return st
setAt st h c '%' = do writeArray (world st) (c,h) (Bug UP RIGHT)
return st
setAt st h c '*' = do writeArray (world st) (c,h) Rock
return st
setAt st h c '@' = do writeArray (world st) (c,h) LamRock
return (st { lambdas = 1 + lambdas st,
totalLams = 1 + totalLams st })
setAt st h c '!' = do writeArray (world st) (c,h) Razor
return st
setAt st h c 'W' = do writeArray (world st) (c,h) (Beard (growthrate st - 1))
return st
setAt st h c '\\' = do writeArray (world st) (c,h) Lambda
return (st { lambdas = 1 + lambdas st,
totalLams = 1 + totalLams st })
setAt st h c t
| t `elem` ['A'..'I']
= do writeArray (world st) (c,h) (Trampoline t)
return $ st { trampLocs = (t, (c, h)) : trampLocs st }
| t `elem` ['1'..'9']
= do writeArray (world st) (c,h) Target
return $ st { trampPath = (t, (c, h)) : trampPath st }
setAt st h c _ = do writeArray (world st) (c,h) Empty
return st
testWorld = let top = take 32 (repeat Wall)
side = Wall : take 30 (repeat Empty) ++ Wall : [] in
mkWorld 32 32 $ top : take 30 (repeat side) ++ top : []
stepWorld t s | mkTrace s
= if (xmove s /= 0 || ymove s /= 0 || shave s || pause s)
then
do printTrace s
hFlush stdout
s <- movePlayer s
s <- moveBugs s
s <- applyRules s
return $ s { timeSinceUpdate = 0,
xmove = 0, ymove = 0,
shave = False, pause = False }
else return s
stepWorld t s = let time = t + timeSinceUpdate s in
if time > 0.1 && not (dead s) then
do s <- movePlayer s
s <- moveBugs s
s <- applyRules s
return $ s { timeSinceUpdate = 0}
else return $ s { timeSinceUpdate = time }
stepSimulate v t (s_in, ('A':cs)) = stepSimulate v t (s_in, []) -- abort
stepSimulate v t (s_in, (c : cs))
| not (dead s_in)
= do let s = mkMove s_in c
s <- movePlayer s
s <- moveBugs s
s <- applyRules s
return (s, cs)
stepSimulate v t (s, [])
| not (dead s)
= do s <- moveBugs s
s <- applyRules s
return (s, [])
stepSimulate v t s = return s
validate s_in ('A' : cs) = validate s_in [] -- abort
validate s_in (c : cs)
| not (dead s_in) && c `elem` "UDLRWS"
= do let s = mkMove s_in c
s <- movePlayer s
s <- moveBugs s
s <- applyRules s
validate s cs
| otherwise = validate s_in cs
validate s _
= do return s
mkMove :: GameState a -> Char -> GameState a
mkMove s 'U' = s { ymove = 1, xmove = 0, shave = False }
mkMove s 'D' = s { ymove = -1, xmove = 0, shave = False }
mkMove s 'L' = s { ymove = 0, xmove = -1, shave = False }
mkMove s 'R' = s { ymove = 0, xmove = 1, shave = False }
mkMove s 'W' = s { ymove = 0, xmove = 0, shave = False }
mkMove s 'S' = s { ymove = 0, xmove = 0, shave = True }
mkMove s _ = s
printTrace :: GameState a -> IO ()
printTrace s
| xmove s == 1 = putStr "R"
| xmove s == -1 = putStr "L"
| ymove s == 1 = putStr "U"
| ymove s == -1 = putStr "D"
| shave s = putStr "S"
| pause s = putStr "W"
printTrace _ = return ()