fearOfView-0.1.1.0: TermDraw.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module TermDraw where
import Control.Concurrent (threadDelay)
import Control.Monad (forM, forM_, mplus, unless, void)
import Control.Monad.State (get, lift, liftIO, put, runStateT)
import Data.Bifunctor (bimap)
import Data.Function (on)
import Data.List (intersperse, minimumBy)
import Data.Maybe (fromMaybe, isJust, isNothing, maybeToList)
import Safe (atMay)
#if !MIN_VERSION_base(4,20,0)
-- foldl' started being exported from prelude in base-4.20.0
import Data.Foldable (foldl')
#endif
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Creature
import CStyle
import Equipment
import Exit
import Geometry
import Group
import Item
import Wall
import Window
import qualified Board as B
import qualified BoardConf as BC
import qualified CPos as CP
import qualified Game as G
import qualified Highscore as HS
import qualified HighscoreFile as HSF
import qualified Inventory as I
import qualified Pos as P
import qualified Power as Pow
import qualified RollFrom as RF
import qualified TermM as TM
import qualified Tutorial as T
invItemGlyph :: InvItem -> Glyph
invItemGlyph e = Glyph c $ CStyle cyan True where
c = case e of
Orb -> 'o'
Cloak -> '['
Umbrella -> '/'
Balloon _ -> '&'
Flash -> '='
Camera _ -> ')'
Tent -> 'A'
Spraypaint _ -> ':'
drawStyledStrs :: TM.TermM m => Window -> CP.CPos -> [(String, CStyle)] -> m ()
drawStyledStrs win (CP.CPos x0 y) = void . (`runStateT` x0) . mapM draw where
draw (s,style) = do
x <- get
lift $ TM.drawStr win style (CP.CPos x y) s
put $ x + length s
twoCharNum :: Int -> String
twoCharNum n | 0 <= n && n < 10 = ' ' : show n
| otherwise = take 2 $ show n
drawStatus :: TM.TermM m => G.Game -> m ()
drawStatus (G.Game { G.life = life, G.maxLife = maxLife, G.score = score, G.level = level, G.round = rnd, G.junk = junk, G.equipment = equipment, G.board = B.Board { B.statuses = statuses } }) = do
let win = StatusWin
unless (M.null statuses) $ drawStyledStrs win (CP.CPos 0 0) statusStrs
drawStyledStrs win (CP.CPos 0 1) numStrs
where
-- XXX: keep in sync with magic numbers in highlightTut
numStrs =
[ ("Life: ", style0)
, (twoCharNum life, lifeStyle)
, ("/", style0)
, (show maxLife, if maxLife == G.initLife then style0 else equipStyle Charm)
, (" Score: ", style0)
, (twoCharNum score <> "/" <> show G.maxScore, style0)
, ("~", scoreStyle)
, (" Level: " <> twoCharNum rnd <> ":", style0)
, (showLevel level, levelStyle level)
] <> if junk == 0 && S.null equipment then [] else
[ (" Junk: ", style0)
, (twoCharNum junk <> "/" <> show (S.size equipment + 2), style0)
, ("%", junkStyle)
]
lifeStyle = case life of
n | n <= 0 -> CStyle (onRed black) True
1 -> CStyle red True
2 -> CStyle red False
3 -> CStyle yellow True
4 -> CStyle yellow False
5 -> style0
6 -> CStyle green False
_ -> CStyle green True
statusStrs = intersperse (" ", style0)
[ (show (fst status) <> " " <> twoCharNum (snd status), statStyle status)
| status <- M.assocs statuses ]
statStyle (B.Dazzled,_) = CStyle cyan True
statStyle (B.Ghost,_) = style0
statStyle (B.Smoke,_) = CStyle blue True
statStyle (B.Haste,n) = CStyle (if n `mod` 2 == 1 then red else yellow) True
statStyle (B.Foresight,_) = styleBold
exitChar :: P.Dir -> Char
exitChar = \case
P.DUp -> '^'
P.DDown -> 'v'
P.DRight -> '>'
P.DLeft -> '<'
drawBoard :: TM.TermM m => B.Board -> m ()
drawBoard = drawAlertedBoard . baseAlerted
data AlertedBoard = AlertedBoard
{ base :: B.Board
, creatureMoves :: M.Map P.WPos Creature
, itemMoves :: M.Map P.WPos Item
, itemUses :: M.Map P.WPos Item
, highlightPs :: S.Set P.Pos
, highlightWPs :: S.Set P.WPos
}
baseAlerted :: B.Board -> AlertedBoard
baseAlerted bd = AlertedBoard bd M.empty M.empty M.empty S.empty S.empty
drawTrans :: TM.TermM m => B.Transition -> m ()
drawTrans (B.Transition bd0 alerts) =
let alerted = foldl' applyAlert (baseAlerted bd0) alerts
in do
drawAlertedBoard alerted
TM.wRefresh BoardWin
TM.wErase BoardWin
liftIO (threadDelay 50000)
where
applyAlert alerted (B.AlertMoveCreature c p d) =
alerted { creatureMoves = M.insert (P.wposInDir p d) c $ creatureMoves alerted
, base = B.modCreatures (M.delete p) $ base alerted
}
applyAlert alerted (B.AlertMoveItem i p d) =
alerted { itemMoves = M.insert (P.wposInDir p d) i $ itemMoves alerted
, base = B.modItems (M.delete p) $ base alerted
}
applyAlert alerted (B.AlertUseItem i p d) =
alerted { itemUses = M.insert (P.wposInDir p d) i $ itemUses alerted
, base = B.modItems (M.delete p) $ base alerted
}
applyAlert alerted (B.AlertHighlight ps wps) =
alerted { highlightPs = ps `S.union` highlightPs alerted
, highlightWPs = wps `S.union` highlightWPs alerted
}
char,bold,dim :: Char -> Glyph
char c = Glyph c style0
bold c = Glyph c styleBold
dim c = Glyph c $ CStyle (onBlue white) False
levelStyle :: Int -> CStyle
levelStyle 1 = CStyle green False
levelStyle 2 = CStyle white True
levelStyle 3 = CStyle yellow True
levelStyle _ = style0
showLevel :: Int -> String
showLevel l | l > 0 = (['A'..] !! (l-1)):""
showLevel _ = "-"
scoreStyle, junkStyle :: CStyle
scoreStyle = CStyle yellow False
junkStyle = CStyle blue True
creatureGlyph :: Creature -> Glyph
creatureGlyph Player = bold '@'
creatureGlyph DeadPlayer = Glyph '@' $ CStyle (onRed black) True
creatureGlyph BasicMonster = Glyph 'm' $ CStyle yellow False
creatureGlyph CalmMonster = Glyph 'p' $ CStyle blue True
creatureGlyph ChaseMonster = Glyph 'c' $ CStyle yellow True
creatureGlyph GhostMonster = Glyph 'g' $ CStyle white True
creatureGlyph SmartMonster = Glyph 's' $ CStyle red True
creatureGlyph (InflatedBalloon charges) = Glyph '0' . CStyle magenta $ charges > 0
itemGlyph :: Item -> Glyph
itemGlyph Gem = Glyph '*' $ CStyle green True
itemGlyph Potion = Glyph '!' $ CStyle green True
itemGlyph MiniPotion = Glyph '!' $ CStyle green False
itemGlyph ScoreTreasure = Glyph '~' scoreStyle
itemGlyph Junk = Glyph '%' junkStyle
itemGlyph (UmbrellaHandle d) = Glyph (if d `elem` [P.DUp, P.DDown] then '|' else '-') $ CStyle magenta True
itemGlyph CameraBoxed = Glyph ')' $ CStyle cyan False
itemGlyph (RollingOrb _ _) = Glyph 'o' $ CStyle cyan False
itemGlyph (ItemInvItem e) = invItemGlyph e
wallGlyphVert :: Wall -> Glyph
wallGlyphVert = \case
BasicWall -> bold wallchar
Pillar -> char '|'
Hedge -> Glyph wallchar $ CStyle green True
ThickHedge -> Glyph '║' $ CStyle green False
Window -> Glyph wallchar $ CStyle cyan False
BrokenWindow -> Glyph ';' $ CStyle cyan False
(CloakWall _ _) -> Glyph wallchar $ CStyle cyan True
(UmbrellaWall d) -> Glyph (if d == P.DRight then '>' else '<') $ CStyle magenta True
TentWall -> Glyph wallchar $ CStyle red True
where wallchar = '│'
wallGlyphHoriz :: Wall -> (Glyph,Glyph)
wallGlyphHoriz = \case
Pillar -> (char '-', char '-')
(UmbrellaWall P.DUp) -> (umb '/', umb '\\')
(UmbrellaWall _) -> (umb '\\', umb '/')
BasicWall -> doublet $ bold wallchar
Hedge -> doublet . Glyph wallchar $ CStyle green True
ThickHedge -> doublet . Glyph '═' $ CStyle green False
Window -> doublet . Glyph wallchar $ CStyle cyan False
BrokenWindow -> (Glyph '.' $ CStyle cyan False , Glyph ',' $ CStyle cyan False)
(CloakWall _ _) -> doublet . Glyph wallchar $ CStyle cyan True
TentWall -> doublet . Glyph wallchar $ CStyle red True
where
wallchar = '─'
umb c = Glyph c $ CStyle magenta True
doublet gl = (gl,gl)
exitGlyphVert :: CStyle -> P.WPos -> Exit -> Glyph
exitGlyphVert st wp = \case
Exit -> bold $ exitChar (P.exitDir wp)
KeyExit -> Glyph (exitChar (P.exitDir wp)) $ equipStyle Key
Entrance -> char 'x'
UnseenBoundary -> char '.'
SeenBoundary -> Glyph '│' st
exitGlyphHoriz :: CStyle -> P.WPos -> Exit -> (Glyph,Glyph)
exitGlyphHoriz st wp = \case
Exit -> (bold $ exitChar (P.exitDir wp), Glyph '─' st)
KeyExit -> (Glyph (exitChar (P.exitDir wp)) $ equipStyle Key, Glyph '─' st)
Entrance -> (char 'x', Glyph '─' st)
UnseenBoundary -> doublet $ char '.'
SeenBoundary -> doublet $ Glyph '─' st
where doublet gl = (gl,gl)
-- positions in board window
posCPosL, posCPosR, posIntCPos :: P.Pos -> CP.CPos
posCPosL (P.Pos x y) = CP.CPos (3*(x+1) - 2) $ 2*(B.h - y) - 1
posCPosR = (CP.CPos 1 0 <>) . posCPosL
posIntCPos p = posCPosL p <> CP.CPos 2 (-1)
wposCPos, wposCPosR :: P.WPos -> CP.CPos
wposCPos (P.WPos p up) = posCPosL p <> if up then CP.CPos 0 (-1) else CP.CPos 2 0
wposCPosR = (CP.CPos 1 0 <>) . wposCPos
drawAlertedBoard :: TM.TermM m => AlertedBoard -> m ()
drawAlertedBoard AlertedBoard{ base = bd, creatureMoves = cmvs, itemMoves = imvs, itemUses = iuses, highlightPs = hps, highlightWPs = hwps } =
let wallsV :: M.Map P.WPos Glyph
wallsH :: M.Map P.WPos (Maybe Glyph,Maybe Glyph)
wallsV = highlightV `M.union` mvingV `M.union` wObscuredV `M.union` bdWallsV `M.union` borderV
wallsH = highlightH `M.union` mvingH `M.union` wObscuredH `M.union` bdWallsH `M.union` borderH
cells, items, creatures, obscured, powers :: M.Map P.Pos (Maybe Glyph,Maybe Glyph)
layer = M.unionWith $ \(l,r) (l',r') -> (l `mplus` l', r `mplus` r')
cells = highlightCells `layer` obscured `layer` creatures `layer` items `layer` powers
filterV = M.filterWithKey $ const . not . P.up
filterH = M.filterWithKey $ const . P.up
filterSV = S.filter $ not . P.up
filterSH = S.filter P.up
glyphsV f m = M.mapWithKey f $ filterV m
glyphsH f m = M.mapWithKey ((bimap Just Just .) . f) $ filterH m
borderV = glyphsV (exitGlyphVert levBoundSt) $ B.exits bd
borderH = glyphsH (exitGlyphHoriz levBoundSt) $ B.exits bd
bdWallsV = glyphsV (const wallGlyphVert) $ B.walls bd
bdWallsH = glyphsH (const wallGlyphHoriz) $ B.walls bd
levBoundSt = levelStyle . BC.level $ B.conf bd
items = M.mapWithKey itemGlyphs $ B.items bd
itemGlyphs p i = (Nothing,) . Just . powerBG p $ itemGlyph i
biGlyph gl = (Just gl, Just gl)
powerBG :: P.Pos -> Glyph -> Glyph
powerBG p
| Just pow <- B.powers bd M.!? p, Pow.charges pow > 0 = modColour onRed
-- | Just pow <- B.powers bd M.!? p, Pow.overUsable pow = modColour onYellow
| otherwise = id
powers = (Nothing,) . Just . powerGlyph <$> B.powers bd
powerGlyph pow = Glyph '"' $ case True of
_ | Pow.charges pow > 0 -> CStyle red True
_ | Pow.overUsable pow -> equipStyle Siphon
_ -> style0
creatures = (,Nothing) . Just . creatureGlyph' <$> B.creatures bd
creatureGlyph' Player = Glyph '@' $ CStyle col (not $ B.ghostly bd) where
col | B.isHasteRound bd = red
| B.hasted bd = yellow
| otherwise = white
creatureGlyph' c = creatureGlyph c
obscured = M.fromSet (\p -> (Just . dim $ expectChar p,) . Just . powerBG p . dim $ obsChar p) $ B.poss S.\\ B.visible bd where
expectChar p
| B.expectant bd
, Just (Just c) <- B.expected bd M.!? p = glyphChar $ creatureGlyph' c
| otherwise = ' '
obsChar p
| p `S.member` B.unrevealed bd = expectedTreasureChar p
| otherwise = ' '
expectedTreasureChar = glyphChar . itemGlyph . B.treasureAt bd
wObscuredV = M.fromSet (const $ dim ' ') . filterSV $ obscuredWPoss
wObscuredH = M.fromSet (const . biGlyph $ dim ' ') . filterSH $ obscuredWPoss
obscuredWPoss = B.invisibleWPoss (B.tagged bd) (B.visible bd)
mvingV = M.map creatureGlyph' (filterV cmvs) `M.union` M.map itemGlyph (filterV $ imvs `M.union` iuses)
mvingH = M.map ((,Nothing) . Just . creatureGlyph') (filterH cmvs)
`M.union` M.map ((Nothing,) . Just . itemGlyph) (filterH imvs)
`M.union` M.map ((,Nothing) . Just . itemGlyph) (filterH iuses)
highlightCells = M.fromSet (const . biGlyph $ bold '#') hps
highlightV = M.fromSet (const $ bold '#') $ filterSV hwps
highlightH = M.fromSet (const . biGlyph $ bold '#') $ filterSH hwps
-- Positions with wall-intersection to top-right
intersections :: M.Map P.Pos Glyph
intersections = iHighlighted `M.union` iObscured `M.union` iWalls
iWalls = M.map (Glyph '·') . M.unionsWith pref $ M.fromList <$>
[ [ (p,i), (p <> if up then P.Pos (-1) 0 else P.Pos 0 (-1),i) ]
| (P.WPos p up, Just i) <- M.toList $
M.map wallI (B.walls bd) `M.union` M.map (const $ Just exitCol) (B.exits bd) ]
where
wallI BasicWall = Just $ CStyle white True
wallI Hedge = Just $ CStyle green True
wallI ThickHedge = Just $ CStyle green False
wallI Pillar = Nothing
wallI Window = Nothing
wallI BrokenWindow = Nothing
wallI (UmbrellaWall _) = Nothing
wallI (CloakWall _ _) = Just $ CStyle cyan True
wallI TentWall = Just $ CStyle red True
exitCol = levBoundSt
pref a b = minimumBy (compare `on` cstyleCol) [a,b] -- white < green < magenta
iObscured = M.fromSet (const $ dim ' ') $ S.filter (\p -> P.x p < B.w-1 && P.y p < B.h-1 &&
and [ p' `S.member` M.keysSet obscured || not (B.inBounds p')
| p' <- (p +^) <$> [ P.Pos x y | x <- [0,1], y <- [0,1] ] ]) B.poss
iHighlighted = M.fromSet (const $ bold '#') $ S.filter (\p -> P.x p < B.w-1 && P.y p < B.h-1 &&
and [ p' `S.member` hps
| p' <- (p +^) <$> [ P.Pos x y | x <- [0,1], y <- [0,1] ] ]) B.poss
horizCPosMap :: M.Map P.Pos (Maybe Glyph, Maybe Glyph) -> M.Map CP.CPos Glyph
horizCPosMap m = M.mapMaybe fst (M.mapKeys posCPosL m) `M.union` M.mapMaybe snd (M.mapKeys posCPosR m)
horizWCPosMap :: M.Map P.WPos (Maybe Glyph, Maybe Glyph) -> M.Map CP.CPos Glyph
horizWCPosMap m = M.mapMaybe fst (M.mapKeys wposCPos m) `M.union` M.mapMaybe snd (M.mapKeys wposCPosR m)
glyphs :: M.Map CP.CPos Glyph
glyphs = M.unions
[ horizCPosMap cells
, M.mapKeys wposCPos wallsV
, horizWCPosMap wallsH
, M.mapKeys posIntCPos intersections
]
in do
sequence_ $ M.mapWithKey (TM.drawGlyph BoardWin) glyphs
drawInv :: TM.TermM m => Maybe I.Slot -> Int -> Bool -> I.Inventory -> Maybe Pow.Power -> m ()
drawInv sel preserve highlightEmpty (I.Inventory inv) pow = do
let win = InvWin
let str x y st = TM.drawStr win st (CP.CPos x y)
str 0 0 styleBold "Inventory:"
sequence_ $
[ do
str 0 slot style (show slot)
case me of
Nothing -> pure ()
Just e -> do
TM.drawGlyph win (CP.CPos 2 slot) (invItemGlyph e)
str 4 slot style $ show e
| slot <- I.slots
, let me = inv M.!? slot
, let style = CStyle col b where
col | slot <= preserve = yellow
| highlightEmpty && isNothing me = red
| otherwise = white
b = sel == Just slot
] <>
[ str 0 (length I.slots + 2) style $ "0 \" " <> show tp <> " " <> show charges <> "/" <> show maxCharges
| Pow.Power tp charges maxCharges overUsable <- maybeToList pow
, let style | overUsable && charges == 0 = equipStyle Siphon
| otherwise = CStyle red $ charges > 0
]
equipStyle :: Equipment -> CStyle
equipStyle Bag = CStyle yellow False
equipStyle Charm = CStyle green True
equipStyle GrabHand = CStyle red False
equipStyle Key = CStyle blue True
equipStyle Siphon = CStyle yellow True
drawEquip :: TM.TermM m => S.Set Equipment -> m ()
drawEquip es | S.null es = pure ()
drawEquip es = do
let win = EquipWin
let str x y st = TM.drawStr win st (CP.CPos x y)
str 0 0 styleBold "Equipment:"
forM_ (zip [1..] (S.toList es)) $ \(y,e) ->
str 0 y (equipStyle e) $ show e
drawMessage :: TM.TermM m => G.Game -> m ()
drawMessage game = do
let win = MessageWin
(text,style) = case G.playState game of
G.Dead -> ("You died with " <> show (G.score game) <>
" points on level " <> show (G.round game) <>
":" <> showLevel (G.level game) <> ". [Space]", styleBold)
G.Won -> ("Congratulations, you win! [Space]", styleBold)
G.Tutorialising b -> (T.text b <> " [Spc/T]", CStyle magenta True)
_ -> ("", style0)
TM.drawStr win style (CP.CPos 0 0) text
drawLevelInfo :: TM.TermM m => B.Board -> m ()
drawLevelInfo bd = do
drawRoll 0 (BC.creatureRoll bc) G.initCreatureSides creatureGlyph
drawRoll 1 (BC.wallRoll bc) G.initWallSides wallGlyphVert
drawDiffsLine 2
where
win = LevelInfoWin
nullGlyph = char '-'
drawRoll :: TM.TermM m => Int -> RF.RollFrom a -> Int -> (a -> Glyph) -> m ()
drawRoll m roll initSides f = sequence_ $
[ TM.drawGlyph win (CP.CPos n m) $ maybe nullGlyph f (RF.vals roll `atMay` n)
| n <- [0 .. RF.sides roll - 1]
] <> [ TM.drawGlyph win (CP.CPos initSides m) $ char ']' ]
bc = B.conf bd
diffs = B.diffs bd
drawDiffsLine y = TM.drawStr win style0 (CP.CPos 0 y) introStr >> sequence_
[ do
draw b . char' $ exitChar dir
draw (b+1) (char ':')
forM (zip [0..] rdfs) (\(x,rdf) -> draw (b+3+x) $ rdfGlyph rdf)
| (n,dir) <- zip [0..] P.dirs
, dir `elem` possibleExitDirs
, let b = length introStr + 8*n
, let char'
| dir `elem` exitDirs = bold
| dir `elem` keyExitDirs = \c -> Glyph c $ equipStyle Key
| otherwise = char
, Just rdfs <- [diffs M.!? dir]
]
where
introStr = "On exit: "
draw x = TM.drawGlyph win (CP.CPos x y)
rdfGlyph (BC.Add (BC.DiffableCreature c)) = creatureGlyph c
rdfGlyph (BC.Swap _ (BC.DiffableCreature c)) = creatureGlyph c
rdfGlyph (BC.Add (BC.DiffableWall wl)) = wallGlyphVert wl
rdfGlyph (BC.Swap _ (BC.DiffableWall wl)) = wallGlyphVert wl
exitsWith ex = P.exitDir <$> M.keys (M.filter (== ex) (B.exits bd))
exitDirs = exitsWith Exit
keyExitDirs = exitsWith KeyExit
possibleExitDirs = exitDirs <> keyExitDirs <> exitsWith UnseenBoundary
data HSInfo
= HSRank Int
| HSAlive
| HSDead
| HSWon
drawMainScreen :: TM.TermM m => G.Game -> m ()
drawMainScreen game = do
let win = MainWin
curHs = twiddle $ G.highscore Nothing game where
twiddle hs = hs { HS.maxLevel = 0, HS.maxRound = HS.maxRound hs + 1 }
centre style y s
| y >= scrH = pure ()
| otherwise = TM.drawStr win style (CP.CPos ((scrW - length s) `div` 2) y) s
drawTitle = sequence_ [ drawStyledStrs win (CP.CPos titleX y) s
| (y,s) <-
[ (0, [ ("·──·──·──·", bdSt), (" ", bgSt) ])
, (1, [ ("│", bdSt), (" Fe@r of", styleBold)
, ("│", bdSt), ("View ", bgSt) ])
, (2, [ ("·──· ·──·", bdSt), (" ", bgSt) ])
]
] where
titleX = (scrW - length "| Fe@r of|View") `div` 2
bdSt = CStyle yellow True
bgSt = CStyle (onBlue white) True
wonStyle = CStyle magenta True
ascii <- TM.asciiOnly
let drawHS :: TM.TermM m => Bool -> Int -> HSInfo -> HS.Highscore -> m ()
drawHS showName y info hs =
drawStyledStrs win (CP.CPos (scoreX showName) y) $
(case info of
HSRank rank -> [(twoCharNum rank, styleBold)]
HSAlive -> [(" @", styleBold)]
HSDead -> [(" ",style0), ("@", CStyle (onRed white) True)]
HSWon -> [(" ",style0), ("@", wonStyle)]
) <>
[ (" ", style0)
] <>
[ (take 8 (fromMaybe "[anon]" (HS.name hs) <> repeat ' ') <> " ", CStyle cyan True)
| showName
] <>
[ (twoCharNum (HS.score hs) <> "~",
if HS.score hs == G.maxScore then wonStyle else scoreStyle)
, (" ", style0)
, (twoCharNum (HS.maxRound hs) <> ":", style0)
, let lev = HS.maxLevel hs in (showLevel lev, levelStyle lev)
] <>
[ (" ", style0) ] <>
[ if e `elem` HS.equipment hs
then (take 1 $ show e, equipStyle e)
else ("-", style0)
| e <- allEquipment ]
scoreX showName = min ((scrW - l) `div` 2) (scrW - l - 1 - aKeyL)
where l = sum $ [length "99 99~ 99:C"]
<> [11 | showName] <> [2 + length allEquipment]
additionalKeys =
[ " More keys:" ]
<> [ "T: Hints" | T.TMeta `S.notMember` G.unseenBeats game ]
<> [ "-: " <> "ASCII " <> (if ascii then "[x]" else "[ ]")
, "Q: Exit" ]
aKeyL = maximum $ length <$> additionalKeys
let keysLine y = centre style0 y "Keys: cursors / WASD / HJKL; 0-9"
drawTitle
if HS.maxRound curHs > 1
then do
centre styleBold 3 "Game in progress:"
drawHS False 4 HSAlive curHs
centre styleBold 6 "Press Space to continue"
else case G.prevHS game of
Just prev -> do
centre style0 3 "Last game:"
let info | HS.score prev >= G.maxScore = HSWon
| otherwise = HSDead
drawHS False 4 info prev
centre styleBold 6 "Press Space to start new game"
Nothing -> centre styleBold 4 "Press Space to start"
keysLine 7
hss <- liftIO HSF.get
unless (null hss) $ do
let someNamed = any (isJust . HS.name) hss
drawStyledStrs win (CP.CPos (scoreX someNamed - 1) 9) $
[ ("Rank ", styleBold) ] <>
[ (" Name ", CStyle cyan True) | someNamed ] <>
[ ("Score ", scoreStyle)
, ("Level ", style0)
, ("Equip", style0) ]
sequence_ [ drawHS someNamed (10+i) (HSRank $ 1+i) hs | (i,hs) <- zip [0..] hss ]
sequence_ [ TM.drawStr win
(CStyle (onBlue white) $ n == 0)
(CP.CPos (scrW - 2 - aKeyL) $ 10 + n) . take aKeyL $ s <> repeat ' '
| (s,n) <- zip additionalKeys [0..]
]
tutBox :: T.Beat -> Maybe (CP.CPos, [Glyph])
tutBox = tutBox' where
tutBox' (T.Movement p) = Just (boardOffset <> posCPosL p, [creatureGlyph Player])
tutBox' (T.Trapped p) = Just (boardOffset <> posCPosL p, [creatureGlyph Player])
tutBox' (T.SeeMonster p c) = Just (boardOffset <> posCPosL p, [creatureGlyph c])
tutBox' (T.SeeExit wp) = Just (boardOffset <> wposCPos wp, [bold . exitChar $ P.exitDir wp])
tutBox' (T.SeeItem p i) = Just (boardOffset <> posCPosR p, [itemGlyph i])
tutBox' (T.SeePotion p) = Just (boardOffset <> posCPosR p, [itemGlyph Potion])
tutBox' (T.SeeMiniPotion p) = Just (boardOffset <> posCPosR p, [itemGlyph MiniPotion])
tutBox' (T.SeeScore p) = Just (boardOffset <> posCPosR p, [itemGlyph ScoreTreasure])
tutBox' (T.SeeJunk p) = Just (boardOffset <> posCPosR p, [itemGlyph Junk])
tutBox' (T.SeeGem p) = Just (boardOffset <> posCPosR p, [itemGlyph Gem])
tutBox' T.CollectItem = Just (invOffset <> CP.CPos 0 1, [char '1'])
tutBox' T.CollectGem = Just (invOffset <> CP.CPos 0 10, [Glyph '0' $ CStyle red True])
tutBox' T.CollectScore = Just (statusOffset <> CP.CPos 20 1, (char <$> (" 1/" <> show G.maxScore)) <> [Glyph '~' scoreStyle])
tutBox' (T.Hurt l ml) = Just (statusOffset <> CP.CPos 6 1, char <$> twoCharNum l <> "/" <> show ml)
tutBox' T.Timer = Just (levelInfoOffset <> CP.CPos (G.initCreatureSides - 4) 0, char <$> "- ]")
tutBox' T.SecondRound = Just (levelInfoOffset <> CP.CPos 0 2, char <$> "On exit:")
tutBox' _ = Nothing
winOffset win = CP.CPos x y where WinDim x y _ _ = geometry M.! win
boardOffset = winOffset BoardWin
invOffset = winOffset InvWin
statusOffset = winOffset StatusWin
levelInfoOffset = winOffset LevelInfoWin
highlightTut :: TM.TermM m => T.Beat -> m ()
highlightTut = maybe (pure ()) (uncurry TM.drawHighlightBoxChars) . tutBox