module Rules where import Data.Array.IO import Control.Monad data Direction = UP | RIGHT | DOWN | LEFT deriving (Show, Eq, Enum) next LEFT = UP next d = succ d prev UP = LEFT prev d = pred d data Tile = Empty | Rock | LamRock | Lambda | Bug Direction Direction | Dirt | Wall | Exit | ExitOpen | Beard Int | Razor | Trampoline Char | Target | Player deriving (Show, Eq) toChar :: Tile -> Char toChar Empty = ' ' toChar Rock = '*' toChar LamRock = '@' toChar (Bug _ _) = '%' toChar Dirt = '.' toChar Wall = '#' toChar Lambda = '\\' toChar Exit = 'L' toChar ExitOpen = 'O' toChar (Beard _) = 'W' toChar Razor = '!' toChar (Trampoline c) = 'T' toChar Target = 't' toChar Player = 'R' data Metadata = Growth Int | Razors Int deriving (Show, Eq) type GameMap = IOArray (Int, Int) Tile data GameState a = GS { bitmaps :: a, playerpos :: (Int, Int), exitpos :: (Int, Int), lambdas :: Int, totalLams :: Int, xmove :: Int, ymove :: Int, score :: Int, razors :: Int, growthrate :: Int, trampPath :: [(Char, (Int, Int))], trampLocs :: [(Char, (Int, Int))], shave :: Bool, pause :: Bool, won :: Bool, dead :: Bool, mkTrace ::Bool, world :: GameMap, waterlevel :: Int, floodrate :: Int, floodstep :: Int, glug :: Int, waterproofing :: Int, oldworld :: GameMap, timeSinceUpdate :: Float, iscale :: Float } printMap :: GameMap -> Int -> IO String printMap m w = do ((wl, hl), (wh, hh)) <- getBounds m strs <- mapM (\row -> do mapM (\col -> do x <- readArray m (col, row) return (toChar x)) [wl..wh]) [hh,hh-1..hl] return (unlines strs) growth :: Int growth = 25 -- steps between beard growth {- rules for tile movement: * A player can make one of the following moves: - Up, Down, Left, Right, Wait (in gameplay, 'Wait' is implied by doing nothing for one game step, say 1/20th of a second) * A player may move to any of the following: - Empty, Dirt - Lambda (increasing score by 1) - Exit (but only if there are no lambdas) - Rock (but only if the rock can be pushed sideways into an Empty space) * When a player moves, the square he moves to becomes Player and the square he vacates becomes Empty After player movement the following rules are applied, in order, to update the map. We apply the rules to points on the map left to right, then bottom to top: * A rock will move DOWN if there is an Empty space below it * A rock will move DOWN and RIGHT if there is a Rock below it and an Empty right, and below and right * A rock will move DOWN and RIGHT if there is a Lambda below it and an Empty right, and below and right * A rock will move DOWN and LEFT if there is a Rock below it and an Empty left, and below and left The game ends in any of the following conditions: * There is a rock directly above the player [Squashed: lose] * There are no lambdas left and the player is at the exit (the lambda lift) [win] -} surrounding s (x, y) = do ((wl, hl), (wh, hh)) <- getBounds (world s) return [(x', y') | x' <- [x-1 .. x+1], y' <- [y-1 .. y+1], (x', y') /= (x, y), (x' >= wl && x' <= wh && y' >= hl && y' <=hh)] applyRules :: GameState a -> IO (GameState a) applyRules s | won s = return s applyRules s = do ((wl, hl), (wh, hh)) <- getBounds (world s) -- read the contents of the world before update, so that we don't -- run into problems when updating tiles that will get updated again -- later. mapM_ (\p -> do x <- readArray (world s) p writeArray (oldworld s) p x) [(x,y) | y <- [hl..hh], x <- [wl..wh] ] squashTest <- mapM update [(x,y) | y <- [hl..hh], x <- [wl..wh]] let squashedLocs = concat squashTest -- better check it's still a rock and not overwritten by a beard! squashed <- mapM (\p -> do c <- readArray (world s) p return (c `elem` [Rock, LamRock, Lambda])) squashedLocs let (_, y) = playerpos s let glug' = if y < waterlevel s then glug s + 1 else 0 let dead' = or squashed || dead s || glug' > waterproofing s let sc = if dead' then score s - (totalLams s - lambdas s) * 25 else score s let fr = floodrate s let (w, fs) = if fr == 0 then (waterlevel s, floodstep s) else if (floodstep s - 1 == 0) then (waterlevel s + 1, floodrate s) else (waterlevel s, floodstep s - 1) return s { dead = dead', glug = glug', score = sc, waterlevel = w, floodstep = fs } where update (x, y) = do t <- readArray (oldworld s) (x, y) case t of Rock -> do below <- readArray (oldworld s) (x, y-1) rt <- readArray (oldworld s) (x+1, y) belowrt <- readArray (oldworld s) (x+1, y-1) lt <- readArray (oldworld s) (x-1, y) belowlt <- readArray (oldworld s) (x-1, y-1) moveRock Rock (x, y) below rt belowrt lt belowlt LamRock -> do below <- readArray (oldworld s) (x, y-1) rt <- readArray (oldworld s) (x+1, y) belowrt <- readArray (oldworld s) (x+1, y-1) lt <- readArray (oldworld s) (x-1, y) belowlt <- readArray (oldworld s) (x-1, y-1) moveRock LamRock (x, y) below rt belowrt lt belowlt Beard 0 -> do writeArray (world s) (x, y) (Beard (growthrate s - 1)) growBeard (x, y) return [] Beard n -> do writeArray (world s) (x, y) (Beard (n - 1)) return [] _ -> return [] growBeard (x, y) = do adj <- surrounding s (x, y) -- any surrounding which are Empty get a Beard growth mapM (\ (x', y') -> do t <- readArray (oldworld s) (x', y') when (t == Empty) $ writeArray (world s) (x', y') (Beard (growthrate s - 1))) adj moveRock r (x, y) Empty _ _ _ _ = do writeArray (world s) (x, y) Empty writeArray (world s) (x, y-1) r s <- checkSquashed (x, y-2) when (r == LamRock) $ checkTransform (x, y-2) (x, y-1) if s then return [(x, y-1)] else return [] moveRock r (x, y) rck Empty Empty _ _ | rck `elem` [Rock, LamRock] = do writeArray (world s) (x, y) Empty writeArray (world s) (x+1, y-1) r s <- checkSquashed (x+1, y-2) when (r == LamRock) $ checkTransform (x+1, y-2) (x+1, y-1) if s then return [(x+1, y-1)] else return [] moveRock r (x, y) Lambda Empty Empty _ _ = do writeArray (world s) (x, y) Empty writeArray (world s) (x+1, y-1) r s <- checkSquashed (x+1, y-2) when (r == LamRock) $ checkTransform (x+1, y-2) (x+1, y-1) if s then return [(x+1, y-1)] else return [] moveRock r (x, y) rck _ _ Empty Empty | rck `elem` [Rock, LamRock] = do writeArray (world s) (x, y) Empty writeArray (world s) (x-1, y-1) r s <- checkSquashed (x-1, y-2) when (r == LamRock) $ checkTransform (x-1, y-2) (x-1, y-1) if s then return [(x-1, y-1)] else return [] moveRock _ _ _ _ _ _ _ = return [] checkSquashed p = do t <- readArray (oldworld s) p case t of Bug _ _ -> do writeArray (world s) p Empty return False Player -> return True _ -> return False checkTransform p p' = do t <- readArray (oldworld s) p when (t /= Empty) $ writeArray (world s) p' Lambda moveBugs :: GameState a -> IO (GameState a) moveBugs s = do ((wl, hl), (wh, hh)) <- getBounds (world s) -- read the contents of the world before update, so that we don't -- run into problems when updating tiles that will get updated again -- later. mapM_ (\p -> do x <- readArray (world s) p writeArray (oldworld s) p x) [(x,y) | x <- [wl..wh], y <- [hl..hh]] eaten <- mapM update [(x,y) | x <- [wl..wh], y <- [hl..hh]] return s { dead = or eaten } where update (x, y) = do t <- readArray (oldworld s) (x, y) case t of Bug d d' -> do (x', y') <- moveBug (x, y) d d' return ((x', y') == playerpos s) _ -> return False moveBug (x, y) d d' = do let (x', y') = getNext (x, y) d' -- trying to go this way let (x'', y'') = getNext (x, y) d -- default this way newtile <- readArray (oldworld s) (x', y') newtile' <- readArray (oldworld s) (x'', y'') case newtile of Empty -> do writeArray (world s) (x, y) Empty writeArray (world s) (x', y') (Bug (next d) (next d')) return (x', y') Player -> do writeArray (world s) (x, y) Empty writeArray (world s) (x', y') (Bug (next d) (next d')) return (x', y') _ -> case newtile' of Empty -> do writeArray (world s) (x, y) Empty writeArray (world s) (x'', y'') (Bug d d') return (x'', y'') Player -> do writeArray (world s) (x, y) Empty writeArray (world s) (x'', y'') (Bug d d') return (x'', y'') _ -> do writeArray (world s) (x, y) (Bug (prev d) (prev d')) return (x, y) getNext (x, y) d = case d of UP -> (x, y + 1) DOWN -> (x, y - 1) LEFT -> (x - 1, y) RIGHT -> (x + 1, y) movePlayer :: GameState a -> IO (GameState a) movePlayer s | won s = return s movePlayer s | dead s = return s movePlayer s | shave s = -- any beard in squares adjacent to the player become Empty do let (x, y) = playerpos s r <- if (razors s > 0) then do adj <- surrounding s (x, y) mapM_ shaveBeard adj return (razors s - 1) else return $ razors s return $ s { shave = False, razors = r, score = score s - 1 } where shaveBeard (x, y) = do t <- readArray (world s) (x, y) case t of Beard _ -> writeArray (world s) (x, y) Empty _ -> return () movePlayer s = do let (x, y) = playerpos s let (x', y') = (x + xmove s, y + ymove s) tile <- readArray (world s) (x', y') -- Can only move onto Empty, Dirt, ExitOpen, Lambda, Razor, Trampoline -- Can move to a rock, if the rock can move into the space in the same -- direction as the player movement execMove tile (x, y) (x', y') (s { score = score s - 1 }) execMove (Trampoline t) (x, y) (x', y') s = case lookup t (trampPath s) of Just (xt, yt) -> do writeArray (world s) (xt, yt) Player writeArray (world s) (x', y') Empty -- Eliminate the trampoline -- Eliminate others to same target mapM_ (\p -> writeArray (world s) p Empty) (trampsTo (xt, yt) (trampLocs s) (trampPath s)) writeArray (world s) (x, y) Empty return $ s { playerpos = (xt, yt) } _ -> return s where trampsTo p [] _ = [] trampsTo p ((c, t):cs) xs = case lookup c xs of Just p' -> if p == p' then t : trampsTo p cs xs else trampsTo p cs xs _ -> trampsTo p cs xs execMove tile (x, y) (x', y') s | tile `elem` [Empty, Dirt, ExitOpen, Lambda, Razor] = do writeArray (world s) (x', y') Player writeArray (world s) (x, y) Empty let lams = case tile of Lambda -> lambdas s - 1 _ -> lambdas s let raz = case tile of Razor -> razors s + 1 _ -> razors s let sc = case tile of Lambda -> score s + 50 ExitOpen -> if (not (won s)) then score s + totalLams s * 25 else score s _ -> score s when (lams == 0) $ writeArray (world s) (exitpos s) ExitOpen return $ s { playerpos = (x', y'), lambdas = lams, razors = raz, score = sc, won = won s || (x', y') == exitpos s } | isBug tile = do writeArray (world s) (x, y) Empty return $ s { dead = True } | (tile == Rock || tile == LamRock) && ymove s == 0 = do tile' <- readArray (world s) (x' + xmove s, y' + ymove s) if tile' == Empty then do writeArray (world s) (x, y) Empty writeArray (world s) (x', y') Player writeArray (world s) (x' + xmove s, y' + ymove s) tile return $ s { playerpos = (x', y') } else return s where isBug (Bug _ _) = True isBug _ = False execMove tile (x, y) (x', y') s = return s