LambdaHack-0.1.20090606: Turn.hs
module Turn where
import Data.List as L
import Data.Map as M
import Data.Set as S
import Data.Char
import Data.Maybe
import Data.Function
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 (sassocs state) (sdiscoveries state) 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, sassocs = assocs, sdiscoveries = discs }))
per oldmsg =
-- 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
do
-- do not make intermediate redraws while running
maybe (displayLevel session lvl per state "") (const $ return ()) pdir
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 = nextEvent session >>= h'
h' e =
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
-- items
"comma" -> pickup h
"d" -> drop h
"i" -> inventory h
"q" -> drink h
-- saving or ending the game
"S" -> saveGame lvl mstate >> shutdown session
"Q" -> shutdown session
"Escape" -> displayCurrent "Press Q to quit." >> h
-- wait
"space" -> loop session nlvl nstate ""
"period" -> loop session nlvl nstate ""
-- look
"colon" -> lookAround 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' "" (unlines (shistory mstate) ++ more) >>= \ b ->
if b then getOptionalConfirm session
(const (displayCurrent "" >> h)) h'
else displayCurrent "" >> h
"I" -> displayCurrent lmeta >> h
"v" -> displayCurrent version >> h
s -> displayCurrent ("unknown command (" ++ s ++ ")") >> h
maybe h continueRun pdir
where
-- we record the oldmsg in the history
mstate = if L.null oldmsg then state else updateHistory state (take 500 . ((oldmsg ++ " "):))
-- TODO: make history max configurable
reachable = preachable per
visible = pvisible per
displayCurrent :: String -> IO ()
displayCurrent = displayLevel session nlvl per state
displayCurrent' :: String -> String -> IO Bool
displayCurrent' = displayOverlay 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 mstate (const nplayer)
-- picking up items
pickup abort = pickupItem
displayCurrent
(\ l p -> loop session l (updatePlayer nstate (const p)))
abort
nlvl nplayer assocs discs
-- dropping items
drop abort = dropItem
session
displayCurrent
displayCurrent'
(\ l p -> loop session l (updatePlayer nstate (const p)))
abort
nlvl nplayer assocs discs
-- drinking potions
drink abort = drinkPotion
session
displayCurrent
displayCurrent'
(\ l p d -> loop session l
(updateDiscoveries (updatePlayer nstate (const p)) (S.union d)))
abort
nlvl nplayer assocs discs
-- display inventory
inventory abort
| L.null (mitems player) =
displayCurrent "You are not carrying anything." >> abort
| otherwise =
do
displayItems displayCurrent' assocs discs
"This is what you are carrying:" True (mitems player)
getConfirm session
displayCurrent ""
abort -- looking at inventory doesn't take any time
-- look around at current location
lookAround abort =
do
-- check if something is here to pick up
let t = nlmap `at` ploc
if length (titems t) <= 2
then displayCurrent (lookAt True assocs discs nlmap ploc) >> abort
else
do
displayItems displayCurrent' assocs discs
(lookAt True assocs discs nlmap ploc) False (titems t)
getConfirm session
displayCurrent ""
abort -- looking around doesn't take any time
-- 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 assocs discs 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 assocs discs 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 assocs discs per APlayer dir
-- | Drinking potions.
drinkPotion :: Session -> -- session
(String -> IO ()) -> -- how to display
(String -> String -> IO Bool) -> -- overlay display
(Level -> Player -> Discoveries -> String -> IO a) ->
-- success continuation
IO a -> -- failure continuation
Level -> -- the level
Player -> -- the player
Assocs ->
Discoveries ->
IO a
drinkPotion session displayCurrent displayCurrent' continue abort
nlvl@(Level { lmap = nlmap }) nplayer@(Monster { mloc = ploc }) assocs discs
| L.null (mitems nplayer) =
displayCurrent "You are not carrying anything." >> abort
| otherwise =
do
i <- getPotions session displayCurrent displayCurrent' assocs discs
"What to drink?" (mitems nplayer)
case i of
Just i'@(Item { itype = Potion ptype }) ->
let iplayer = nplayer { mitems = deleteBy ((==) `on` iletter) i' (mitems nplayer) }
t = nlmap `at` ploc
msg = subjectMonster (mtype nplayer) ++ " " ++
verbMonster (mtype nplayer) "drink" ++ " " ++
objectItem assocs discs (icount i') (itype i') ++ ". " ++
pmsg ptype
pmsg PotionWater = "Tastes like water."
pmsg PotionHealing = "You feel better."
fplayer PotionWater = iplayer
fplayer PotionHealing = iplayer { mhp = 20 }
in continue nlvl
(fplayer ptype) (S.singleton (itype i')) msg
Just _ -> displayCurrent "you cannot drink that" >> abort
Nothing -> displayCurrent "never mind" >> abort
-- | Dropping items.
dropItem :: Session -> -- session
(String -> IO ()) -> -- how to display
(String -> String -> IO Bool) -> -- overlay display
(Level -> Player -> String -> IO a) -> -- success continuation
IO a -> -- failure continuation
Level -> -- the level
Player -> -- the player
Assocs ->
Discoveries ->
IO a
dropItem session displayCurrent displayCurrent' continue abort
nlvl@(Level { lmap = nlmap }) nplayer@(Monster { mloc = ploc }) assocs discs
| L.null (mitems nplayer) =
displayCurrent "You are not carrying anything." >> abort
| otherwise =
do
i <- getAnyItem session displayCurrent displayCurrent' assocs discs
"What to drop?" (mitems nplayer)
case i of
Just i' -> let iplayer = nplayer { mitems = deleteBy ((==) `on` iletter) i' (mitems nplayer) }
t = nlmap `at` ploc
nt = t { titems = snd (joinItem i' (titems t)) }
plmap = M.insert ploc (nt, nt) nlmap
msg = subjectMonster (mtype nplayer) ++ " " ++
verbMonster (mtype nplayer) "drop" ++ " " ++
objectItem assocs discs (icount i') (itype i') ++ "."
in continue (updateLMap nlvl (const plmap))
iplayer msg
Nothing -> displayCurrent "never mind" >> abort
-- | Picking up items.
pickupItem :: (String -> IO ()) -> -- how to display
(Level -> Player -> String -> IO a) -> -- success continuation
IO a -> -- failure continuation
Level -> -- the level
Player -> -- the player
Assocs ->
Discoveries ->
IO a
pickupItem displayCurrent continue abort
nlvl@(Level { lmap = nlmap }) nplayer@(Monster { mloc = ploc }) assocs discs =
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 (iletter i) (mletter nplayer) (mitems nplayer) of
Just l ->
let msg = -- (complete sentence, more adequate for monsters)
{-
subjectMonster (mtype player) ++ " " ++
compoundVerbMonster (mtype player) "pick" "up" ++ " " ++
objectItem (icount i) (itype i) ++ "."
-}
letterLabel (iletter ni) ++ objectItem assocs discs (icount ni) (itype ni)
nt = t { titems = rs }
plmap = M.insert ploc (nt, nt) nlmap
(ni,nitems) = joinItem (i { iletter = Just l }) (mitems nplayer)
iplayer = nplayer { mitems = nitems,
mletter = maxLetter l (mletter nplayer) }
in continue (updateLMap nlvl (const plmap))
iplayer msg
Nothing -> displayCurrent "cannot carry anymore" >> abort
getPotions :: Session ->
(String -> IO ()) ->
(String -> String -> IO Bool) ->
Assocs ->
Discoveries ->
String ->
[Item] ->
IO (Maybe Item)
getPotions session displayCurrent displayCurrent' assocs discs prompt is =
getItem session displayCurrent displayCurrent' assocs discs
prompt (\ i -> case itype i of Potion {} -> True; _ -> False)
"Potions in your inventory:" is
getAnyItem :: Session ->
(String -> IO ()) ->
(String -> String -> IO Bool) ->
Assocs ->
Discoveries ->
String ->
[Item] ->
IO (Maybe Item)
getAnyItem session displayCurrent displayCurrent' assocs discs prompt is =
getItem session displayCurrent displayCurrent' assocs discs
prompt (const True) "Objects in your inventory:" is
getItem :: Session ->
(String -> IO ()) ->
(String -> String -> IO Bool) ->
Assocs ->
Discoveries ->
String ->
(Item -> Bool) ->
String ->
[Item] ->
IO (Maybe Item)
getItem session displayCurrent displayCurrent' assocs discs prompt p ptext is0 =
let is = L.filter p is0
choice | L.null is = "[*]"
| otherwise = "[" ++ letterRange (concatMap (maybeToList . iletter) is) ++ " or ?*]"
r = do
displayCurrent (prompt ++ " " ++ choice)
let h = nextEvent session >>= h'
h' e =
handleModifier e h $
case e of
"question" -> do
b <- displayItems displayCurrent' assocs discs
ptext True is
if b then getOptionalConfirm session (const r) h'
else r
"asterisk" -> do
b <- displayItems displayCurrent' assocs discs
"Objects in your inventory:" True is0
if b then getOptionalConfirm session (const r) h'
else r
[l] -> return (find (\ i -> maybe False (== l) (iletter i)) is0)
_ -> return Nothing
h
in r
displayItems displayCurrent' assocs discs msg sorted is =
do
let inv = unlines $
L.map (\ (Item { icount = c, iletter = l, itype = t }) ->
letterLabel l ++ objectItem assocs discs c t ++ " ")
((if sorted then sortBy (cmpLetter' `on` iletter) else id) is)
let ovl = inv ++ more
displayCurrent' msg ovl
moveOrAttack :: Bool -> -- allow attacks?
(Level -> Player -> String -> IO a) -> -- success continuation
IO a -> -- failure continuation
Level -> -- the level
Player -> -- the player
Assocs ->
Discoveries ->
Perception -> -- perception of the player
Actor -> -- who's moving?
Dir -> IO a
moveOrAttack allowAttacks
continue abort
nlvl@(Level { lmap = nlmap }) player assocs discs 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 assocs discs 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 = [ APlayer | mloc player == naloc ]
attackedMonsters = L.map AMonster $
findIndices (\ m -> mloc m == naloc) (lmonsters nlvl)
attacked :: [Actor]
attacked = attackedPlayer ++ attackedMonsters