LambdaHack-0.1.20080413: Turn.hs
module Turn where
import Data.List as L
import Data.Map as M
import Data.Set as S
import Data.Char
import State
import Geometry
import Level
import Dungeon
import Monster
import Actor
import Perception
import Item
import Display2
import Random
import Save
import Message
import Version
import Strategy
-- | Perform a complete turn (i.e., monster moves etc.)
loop :: Session -> Level -> State -> String -> IO ()
loop session (lvl@(Level nm sz ms smap lmap lmeta))
(state@(State { splayer = player@(Monster { mhp = php, mloc = ploc }), stime = time }))
oldmsg =
do
-- update smap
let nsmap = M.insert ploc (time + smellTimeout) smap
-- determine player perception
let per = perception ploc lmap
-- perform monster moves
handleMonsters session (lvl { lsmell = nsmap }) state per oldmsg
-- | Handle monster moves. The idea is that we perform moves
-- as long as there are monsters that have a move time which is
-- less than or equal to the current time.
handleMonsters :: Session -> Level -> State -> Perception -> String -> IO ()
handleMonsters session lvl@(Level { lmonsters = ms })
(state@(State { stime = time }))
per oldmsg =
-- for debugging: causes redraw of the current state for every monster move; slow!
-- displayLevel session lvl per state oldmsg >>
case ms of
[] -> -- there are no monsters, just continue
handlePlayer
(m@(Monster { mtime = mt }) : ms)
| mt > time -> -- all the monsters are not yet ready for another move,
-- so continue
handlePlayer
| mhp m <= 0 -> -- the monster dies
handleMonsters session (updateMonsters lvl (const ms))
state per oldmsg
| otherwise -> -- monster m should move
handleMonster m session (updateMonsters lvl (const ms))
state per oldmsg
where
nstate = state { stime = time + 1 }
-- good place to do everything that has to be done for every *time*
-- unit; currently, that's monster generation
handlePlayer =
do
nlvl <- rndToIO (addMonster lvl (splayer nstate))
handle session nlvl nstate per oldmsg
-- | Handle the move of a single monster.
handleMonster :: Monster -> Session -> Level -> State -> Perception -> String ->
IO ()
handleMonster m session lvl@(Level { lmonsters = ms, lsmell = nsmap, lmap = lmap })
(state@(State { splayer = player@(Monster { mloc = ploc }), stime = time }))
per oldmsg =
do
nl <- rndToIO (frequency (head (runStrategy (strategy m lvl state per .| wait))))
-- increase the monster move time and set direction
let nm = m { mtime = time + mspeed m, mdir = if nl == (0,0) then Nothing else Just nl }
let (act, nms) = insertMonster nm ms
let nlvl = updateMonsters lvl (const nms)
moveOrAttack
True
(\ nlvl np msg ->
handleMonsters session nlvl (updatePlayer state (const np)) per
(addMsg oldmsg msg))
(handleMonsters session nlvl state per oldmsg)
nlvl player per
(AMonster act)
nl
strategy :: Monster -> Level -> State -> Perception -> Strategy Loc
strategy m@(Monster { mtype = mt, mloc = me, mdir = mdir })
lvl@(Level { lmonsters = ms, lsmell = nsmap, lmap = lmap })
(state@(State { splayer = player@(Monster { mloc = ploc }), stime = time }))
per =
case mt of
Eye -> eye
FastEye -> eye
Nose -> nose
_ -> onlyAccessible moveRandomly
where
-- we check if the monster is visible by the player rather than if the
-- player is visible by the monster -- this is more efficient, but
-- won't be correct in the general situation
playerVisible = me `S.member` pvisible per
playerAdjacent = adjacent me ploc
towardsPlayer = towards (me, ploc)
onlyTowardsPlayer = only (\ x -> distance (towardsPlayer, x) <= 1)
onlyPreservesDir = only (\ x -> maybe True (\ d -> distance (neg d, x) > 1) mdir)
onlyUnoccupied = onlyMoves (unoccupied ms lmap) me
onlyAccessible = onlyMoves (accessible lmap me) me
smells = L.map fst $
L.sortBy (\ (_,s1) (_,s2) -> compare s2 s1) $
L.filter (\ (_,s) -> s > 0) $
L.map (\ x -> (x, nsmap ! (me `shift` x) - time `max` 0)) moves
eye = playerAdjacent .=> return towardsPlayer
.| (onlyUnoccupied $ onlyAccessible $
playerVisible .=> onlyTowardsPlayer moveRandomly
.| onlyPreservesDir moveRandomly)
nose = playerAdjacent .=> return towardsPlayer
.| (onlyAccessible $
foldr (.|) reject (L.map return smells)
.| moveRandomly)
onlyMoves :: (Dir -> Bool) -> Loc -> Strategy Dir -> Strategy Dir
onlyMoves p l = only (\ x -> p (l `shift` x))
moveRandomly :: Strategy Dir
moveRandomly = liftFrequency $ uniform moves
wait :: Strategy Dir
wait = return (0,0)
-- | Display current status and handle the turn of the player.
handle :: Session -> Level -> State -> Perception -> String -> IO ()
handle session (lvl@(Level nm sz ms smap lmap lmeta))
(state@(State { splayer = player@(Monster { mhp = php, mdir = pdir, mloc = ploc, mitems = pinv, mtime = ptime }), stime = time }))
per oldmsg =
do
-- check for player death
if php <= 0
then do
displayCurrent (addMsg oldmsg ("You die ..." ++ more))
getConfirm session
shutdown session
else -- check if the player can make another move yet
if ptime > time then handleMonsters session lvl state per oldmsg
-- NOTE: It's important to call handleMonsters here, not loop,
-- because loop does all sorts of calculations that are only
-- really necessary after the player has moved.
else do
displayCurrent oldmsg
let h = do
e <- nextEvent session
handleDirection e (move h) $
handleDirection (L.map toLower e) run $
handleModifier e h $
case e of
"o" -> openclose True h
"c" -> openclose False h
"s" -> search h
"less" -> lvlchange Up h
"greater" -> lvlchange Down h
"comma" -> pickup h
-- saving or ending the game
"S" -> saveGame lvl state >> shutdown session
"Q" -> shutdown session
"Escape" -> shutdown session
-- wait
"space" -> loop session nlvl nstate ""
"period" -> loop session nlvl nstate ""
-- look
"colon" -> displayCurrent (lookAt True nlmap ploc) >> h
-- display modes
"V" -> handle session nlvl (toggleVision state) per oldmsg
"R" -> handle session nlvl (toggleSmell state) per oldmsg
"O" -> handle session nlvl (toggleOmniscient state) per oldmsg
"T" -> handle session nlvl (toggleTerrain state) per oldmsg
-- meta information
"M" -> displayCurrent lmeta >> h
"v" -> displayCurrent version >> h
s -> displayCurrent ("unknown command (" ++ s ++ ")") >> h
maybe h continueRun pdir
where
reachable = preachable per
visible = pvisible per
displayCurrent = displayLevel session nlvl per state
-- update player memory
nlmap = foldr (\ x m -> M.update (\ (t,_) -> Just (t,t)) x m) lmap (S.toList visible)
nlvl = updateLMap lvl (const nlmap)
-- update player action time, and regenerate hitpoints
-- player HP regeneration, TODO: remove hardcoded max and time interval
nplayer = player { mtime = time + mspeed player,
mhp = if time `mod` 1500 == 0 then (php + 1) `min` playerHP else php }
nstate = updatePlayer state (const nplayer)
-- picking up items
pickup abort =
do
-- check if something is here to pick up
let t = nlmap `at` ploc
case titems t of
[] -> displayCurrent "nothing here" >> abort
(i:rs) ->
case assignLetter (mletter nplayer) (mitems nplayer) of
Just l ->
let msg = -- (complete sentence, more adequate for monsters)
{-
subjectMonster (mtype player) ++ " " ++
compoundVerbMonster (mtype player) "pick" "up" ++ " " ++
objectItem (itype i) ++ "."
-}
[l] ++ " - " ++ objectItem (itype i)
nt = t { titems = rs }
plmap = M.insert ploc (nt, nt) nlmap
iplayer = nplayer { mitems = i { iletter = Just l } : mitems nplayer,
mletter = l }
in loop session (updateLMap lvl (const plmap))
(updatePlayer nstate (const iplayer)) msg
Nothing -> displayCurrent "cannot carry anymore" >> abort
-- open and close doors
openclose o abort =
do
displayCurrent "direction?"
e <- nextEvent session
handleDirection e (openclose' o abort) (displayCurrent "never mind" >> abort)
openclose' o abort dir =
let txt = if o then "open" else "closed"
dloc = shift ploc dir
in
case nlmap `at` dloc of
Tile d@(Door hv o') is
| secret o' -> displayCurrent "never mind" >> abort
| toOpen (not o) /= o'
-> displayCurrent ("already " ++ txt) >> abort
| not (unoccupied ms nlmap dloc)
-> displayCurrent "blocked" >> abort
| otherwise -> -- ok, we can open/close the door
let nt = Tile (Door hv (toOpen o)) is
clmap = M.insert (shift ploc dir) (nt, nt) nlmap
in loop session (updateLMap lvl (const clmap)) nstate ""
_ -> displayCurrent "never mind" >> abort
-- search for secret doors
search abort =
let searchTile (Tile (Door hv (Just n)) x,t') = Just $ (Tile (Door hv (Just (max (n - 1) 0))) x, t')
searchTile t = Just t
slmap = foldl (\ l m -> update searchTile (shift ploc m) l) nlmap moves
in loop session (updateLMap lvl (const slmap)) nstate ""
-- perform a level change
lvlchange vdir abort =
case nlmap `at` ploc of
Tile (Stairs vdir' next) is
| vdir == vdir' -> -- ok
case next of
Nothing -> -- exit dungeon
shutdown session
Just (nln, nloc) ->
-- perform level change
do
-- put back current level
-- (first put back, then get, in case we change to the same level!)
let full = putDungeonLevel lvl (sdungeon nstate)
-- get new level
(new, ndng) = getDungeonLevel nln full
lstate = nstate { sdungeon = ndng }
loop session new (updatePlayer lstate (const (player { mloc = nloc }))) ""
_ -> -- no stairs
let txt = if vdir == Up then "up" else "down" in
displayCurrent ("no stairs " ++ txt) >> abort
-- run into a direction
run dir =
do
let mplayer = nplayer { mdir = Just dir }
abort = handle session nlvl (updatePlayer state (const $ player { mdir = Nothing })) per ""
moveOrAttack
False -- attacks are disallowed while running
(\ l p -> loop session l (updatePlayer nstate (const p)))
abort
nlvl mplayer per APlayer dir
continueRun dir =
let abort = handle session nlvl (updatePlayer state (const $ player { mdir = Nothing })) per oldmsg
dloc = shift ploc dir
in case (oldmsg, nlmap `at` ploc) of
(_:_, _) -> abort
(_, Tile (Opening _) _) -> abort
(_, Tile (Door _ _) _) -> abort
(_, Tile (Stairs _ _) _) -> abort
_
| accessible nlmap ploc dloc ->
moveOrAttack
False -- attacks are disallowed while running
(\ l p -> loop session l (updatePlayer nstate (const p)))
abort
nlvl nplayer per APlayer dir
(_, Tile Corridor _) -- direction change restricted to corridors
| otherwise ->
let ns = L.filter (\ x -> distance (neg dir,x) > 1
&& accessible nlmap ploc (ploc `shift` x)) moves
sns = L.filter (\ x -> distance (dir,x) <= 1) ns
in case ns of
[newdir] -> run newdir
_ -> case sns of
[newdir] -> run newdir
_ -> abort
_ -> abort
-- perform a player move
move abort dir = moveOrAttack
True -- attacks are allowed
(\ l p -> loop session l (updatePlayer nstate (const p)))
abort
nlvl nplayer per APlayer dir
moveOrAttack :: Bool -> -- allow attacks?
(Level -> Player -> String -> IO a) -> -- success continuation
IO a -> -- failure continuation
Level -> -- the level
Player -> -- the player
Perception -> -- perception of the player
Actor -> -- who's moving?
Dir -> IO a
moveOrAttack allowAttacks
continue abort
nlvl@(Level { lmap = nlmap }) player per
actor dir
-- to prevent monsters from hitting themselves
| dir == (0,0) = continue nlvl player ""
-- At the moment, we check whether there is a monster before checking accessibility
-- i.e., we can attack a monster on a blocked location. For instance,
-- a monster on an open door can be attacked diagonally, and a
-- monster capable of moving through walls can be attacked from an
-- adjacent position.
| not (L.null attacked) =
if allowAttacks then
do
let damage m = case mhp m of
1 -> m { mhp = 0, mtime = 0 } -- grant an immediate move to die
h -> m { mhp = h - 1 }
let combatVerb m
| mhp m > 0 = "hit"
| otherwise = "kill"
let combatMsg m = subjectMonster (mtype am) ++ " " ++
verbMonster (mtype am) (combatVerb m) ++ " " ++
objectMonster (mtype m) ++ "."
let perceivedMsg m
| mloc m `S.member` pvisible per = combatMsg m
| otherwise = "You hear some noises."
let sortmtime = sortBy (\ x y -> compare (mtime x) (mtime y))
let updateVictims l p msg (a:r) =
updateActor damage (\ m l p -> updateVictims l p
(addMsg msg (perceivedMsg m)) r)
a l p
updateVictims l p msg [] = continue l {- (updateMonsters l sortmtime) -} p msg
updateVictims nlvl player "" attacked
else
abort
-- Perform a move.
| accessible nlmap aloc naloc =
updateActor (\ m -> m { mloc = naloc })
(\ _ l p -> continue l p (if actor == APlayer
then lookAt False nlmap naloc else ""))
actor nlvl player
| otherwise = abort
where am :: Monster
am = getActor nlvl player actor
aloc :: Loc
aloc = mloc am
source = nlmap `at` aloc
naloc = shift aloc dir
target = nlmap `at` naloc
attackedPlayer = if mloc player == naloc then [APlayer] else []
attackedMonsters = L.map AMonster $
findIndices (\ m -> mloc m == naloc) (lmonsters nlvl)
attacked :: [Actor]
attacked = attackedPlayer ++ attackedMonsters