Allure-0.4.1: src/Display.hs
{-# LANGUAGE CPP #-}
module Display where
-- wrapper for selected Display frontend
#ifdef CURSES
import qualified Display.Curses as D
#elif GTK
import qualified Display.Gtk as D
#else
import qualified Display.Vty as D
#endif
-- Display routines that are independent of the selected display frontend.
import qualified Data.Char as Char
import Data.Set as S
import Data.List as L
import Data.Map as M
import qualified Data.IntMap as IM
import Control.Monad.State hiding (State) -- for MonadIO, seems to be portable between mtl-1 and 2
import Data.Maybe
import Message
import qualified Color
import State
import Geometry
import Level
import LevelState
import Dungeon
import Perception
import Movable
import MovableState
import MovableKind
import Item
import qualified Keys as K
import WorldLoc
-- Re-exported from the display frontend, with an extra slot for function
-- for translating keys to a canonical form.
type InternalSession = D.Session
type Session = (InternalSession, M.Map K.Key K.Key)
display area = D.display area . fst
startup = D.startup
shutdown = D.shutdown . fst
displayId = D.displayId
-- | Next event translated to a canonical form.
nextCommand :: MonadIO m => Session -> m K.Key
nextCommand session =
do
e <- liftIO $ D.nextEvent (fst session)
return $
case M.lookup e (snd session) of
Just key -> key
Nothing -> K.canonMoveKey e
-- | Displays a message on a blank screen. Waits for confirmation.
displayBlankConfirm :: Session -> String -> IO Bool
displayBlankConfirm session txt =
let x = txt ++ more
doBlank = const (Color.defaultAttr, ' ')
in do
display ((0, 0), normalLevelSize) session doBlank x ""
getConfirm session
-- | Waits for a space or return or '?' or '*'. The last two act this way,
-- to let keys that request information toggle display the information off.
getConfirm :: MonadIO m => Session -> m Bool
getConfirm session =
getOptionalConfirm return (const $ getConfirm session) session
getOptionalConfirm :: MonadIO m =>
(Bool -> m a) -> (K.Key -> m a) -> Session -> m a
getOptionalConfirm h k session =
do
e <- liftIO $ nextCommand session
case e of
K.Char ' ' -> h True
K.Char '?' -> h True
K.Char '*' -> h True
K.Return -> h True
K.Esc -> h False
_ -> k e
-- | A yes-no confirmation.
getYesNo :: MonadIO m => Session -> m Bool
getYesNo session =
do
e <- liftIO $ nextCommand session
case e of
K.Char 'y' -> return True
K.Char 'n' -> return False
K.Esc -> return False
_ -> getYesNo session
splitOverlay :: Int -> String -> [[String]]
splitOverlay s xs = splitOverlay' (lines xs)
where
splitOverlay' ls
| length ls <= s = [ls] -- everything fits on one screen
| otherwise = let (pre,post) = splitAt (s - 1) ls
in (pre ++ [more]) : splitOverlay' post
-- | Returns a function that looks up the characters in the
-- string by location. Takes the height of the display plus
-- the string. Returns also the number of screens required
-- to display all of the string.
stringByLocation :: Y -> String -> (Int, Loc -> Maybe Char)
stringByLocation sy xs =
let
ls = splitOverlay sy xs
m = M.fromList (zip [0..] (L.map (M.fromList . zip [0..]) (concat ls)))
k = length ls
in
(k, \ (y,x) -> M.lookup y m >>= \ n -> M.lookup x n)
displayLevel ::
Bool -> Session -> Perceptions -> State -> Message -> Maybe String -> IO Bool
displayLevel
blackAndWhite session per
(state@(State { scursor = cursor,
stime = time,
sassocs = assocs,
slevel = Level ln _ (sy, sx) _ smap lmap _ }))
msg moverlay =
let Movable { mkind = MovableKind { nhpMax = xhp },
mhp = php, mloc = ploc, mitems = pitems } = getPlayerBody state
reachable = ptreachable per
visible = ptvisible per
overlay = fromMaybe "" moverlay
(n, over) = stringByLocation (sy+1) overlay -- n overlay screens needed
sSml = ssensory state == Smell
sVis = case ssensory state of Vision _ -> True; _ -> False
sOmn = sdisplay state == Omniscient
lAt = if sOmn then at else rememberAt
sVisBG = if sVis
then \ vis rea -> if vis
then Color.Blue
else if rea
then Color.Magenta
else Color.defBG
else \ vis rea -> Color.defBG
wealth = L.sum $ L.map itemPrice pitems
damage = case strongestItem pitems "sword" of
Just sw -> 3 + ipower sw
Nothing -> 3
hs = levelHeroList state
ms = levelMonsterList state
dis n loc =
let tile = lmap `lAt` loc
sml = ((smap ! loc) - time) `div` 100
viewMovable loc (Movable { mkind = mk })
| loc == ploc && ln == creturnLn cursor =
(nsymbol mk, Color.defBG) -- highlight player
| otherwise = (nsymbol mk, ncolor mk)
viewSmell :: Int -> Char
viewSmell n
| n > 9 = '*'
| n < 0 = '-'
| otherwise = Char.intToDigit n
rainbow loc = toEnum ((fst loc + snd loc) `mod` 14 + 1)
(char, fg) =
case L.find (\ m -> loc == mloc m) (hs ++ ms) of
Just m | sOmn || vis -> viewMovable loc m
_ | sSml && sml >= 0 -> (viewSmell sml, rainbow loc)
| otherwise -> viewTile vis tile assocs
vis = S.member loc visible
rea = S.member loc reachable
bg = if ctargeting cursor && loc == clocation cursor
then Color.defFG -- highlight targeting cursor
else sVisBG vis rea -- FOV debug
reverseVideo = (snd Color.defaultAttr, fst Color.defaultAttr)
optVisually (fg, bg) =
if fg == Color.defBG
then reverseVideo
else if bg == Color.defFG && fg == Color.defFG
then reverseVideo
else (fg, bg)
a = if blackAndWhite
then Color.defaultAttr
else optVisually (fg, bg)
in case over (loc `shift` ((sy+1) * n, 0)) of
Just c -> (Color.defaultAttr, c)
_ -> (a, char)
status =
take 30 (levelName ln ++ repeat ' ') ++
take 10 ("T: " ++ show (time `div` 10) ++ repeat ' ') ++
take 10 ("$: " ++ show wealth ++ repeat ' ') ++
take 10 ("Dmg: " ++ show damage ++ repeat ' ') ++
take 20 ("HP: " ++ show php ++ " (" ++ show xhp ++ ")" ++ repeat ' ')
disp n msg = display ((0, 0), (sy, sx)) session (dis n) msg status
msgs = splitMsg sx msg
perf k [] = perfo k ""
perf k [xs] = perfo k xs
perf k (x:xs) = disp n (x ++ more) >> getConfirm session >>= \ b ->
if b then perf k xs else return False
perfo k xs
| k < n - 1 = disp k xs >> getConfirm session >>= \ b ->
if b then perfo (k+1) xs else return False
| otherwise = disp k xs >> return True
in perf 0 msgs