lifter-0.1: src/Rules.hs
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