module Game.LambdaHack.Client.UI.WidgetClient
( displayMore, displayYesNo, displayChoiceUI, displayPush, displayPushIfLid
, promptToSlideshow, overlayToSlideshow, overlayToBlankSlideshow
, animate, fadeOutOrIn
) where
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import Data.Maybe
import Data.Monoid
import Game.LambdaHack.Client.BfsClient
import qualified Game.LambdaHack.Client.Key as K
import Game.LambdaHack.Client.MonadClient hiding (liftIO)
import Game.LambdaHack.Client.State
import Game.LambdaHack.Client.UI.Animation
import Game.LambdaHack.Client.UI.DrawClient
import Game.LambdaHack.Client.UI.MonadClientUI
import Game.LambdaHack.Common.ClientOptions
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.State
import Game.LambdaHack.Content.ModeKind
getYesNo :: MonadClientUI m => SingleFrame -> m Bool
getYesNo frame = do
let keys = [ K.KM {key=K.Char 'y', modifier=K.NoModifier}
, K.KM {key=K.Char 'n', modifier=K.NoModifier}
, K.escKM
]
K.KM {key} <- promptGetKey keys frame
case key of
K.Char 'y' -> return True
_ -> return False
displayMore :: MonadClientUI m => ColorMode -> Msg -> m Bool
displayMore dm prompt = do
slides <- promptToSlideshow $ prompt <+> moreMsg
getInitConfirms dm [] $ slides <> toSlideshow False [[]]
displayYesNo :: MonadClientUI m => ColorMode -> Msg -> m Bool
displayYesNo dm prompt = do
sli <- promptToSlideshow $ prompt <+> yesnoMsg
frame <- drawOverlay False dm $ head . snd $ slideshow sli
getYesNo frame
displayChoiceUI :: MonadClientUI m
=> Msg -> Overlay -> [K.KM] -> m (Either Slideshow K.KM)
displayChoiceUI prompt ov keys = do
(_, ovs) <- fmap slideshow $ overlayToSlideshow (prompt <> ", ESC]") ov
let legalKeys = [K.spaceKM, K.escKM]
++ keys
loop [] = fmap Left $ promptToSlideshow "never mind"
loop (x : xs) = do
frame <- drawOverlay False ColorFull x
km@K.KM {..} <- promptGetKey legalKeys frame
case key of
K.Esc -> fmap Left $ promptToSlideshow "never mind"
K.Space -> loop xs
_ -> return $ Right km
loop ovs
displayPush :: MonadClientUI m => m ()
displayPush = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
sls <- promptToSlideshow ""
let slide = head . snd $ slideshow sls
underAI = playerAI $ gplayer fact
frame <- drawOverlay False ColorFull slide
srunning <- getsClient srunning
lastPlay <- getsClient slastPlay
displayFrame (isJust srunning || not (null lastPlay) || underAI)
(Just frame)
displayPushIfLid :: MonadClientUI m => LevelId -> m ()
displayPushIfLid lid = do
arena <- getArenaUI
when (arena == lid) displayPush
promptToSlideshow :: MonadClientUI m => Msg -> m Slideshow
promptToSlideshow prompt = overlayToSlideshow prompt emptyOverlay
overlayToSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow
overlayToSlideshow prompt overlay = do
lid <- getArenaUI
Level{lxsize, lysize} <- getLevel lid
sreport <- getsClient sreport
let msg = splitReport lxsize (addMsg sreport prompt)
return $! splitOverlay False (lysize + 1) msg overlay
overlayToBlankSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow
overlayToBlankSlideshow prompt overlay = do
lid <- getArenaUI
Level{lysize} <- getLevel lid
return $! splitOverlay True (lysize + 3) (toOverlay [prompt]) overlay
animate :: MonadClientUI m => LevelId -> Animation -> m Frames
animate arena anim = do
sreport <- getsClient sreport
mleader <- getsClient _sleader
Level{lxsize, lysize} <- getLevel arena
tgtPos <- leaderTgtToPos
cursorPos <- cursorToPos
let anyPos = fromMaybe (Point 0 0) cursorPos
pathFromLeader leader = fmap Just $ getCacheBfsAndPath leader anyPos
bfsmpath <- maybe (return Nothing) pathFromLeader mleader
tgtDesc <- maybe (return ("------", Nothing)) targetDescLeader mleader
cursorDesc <- targetDescCursor
let over = renderReport sreport
topLineOnly = truncateToOverlay over
basicFrame <-
draw False ColorFull arena cursorPos tgtPos
bfsmpath cursorDesc tgtDesc topLineOnly
snoAnim <- getsClient $ snoAnim . sdebugCli
return $! if fromMaybe False snoAnim
then [Just basicFrame]
else renderAnim lxsize lysize basicFrame anim
fadeOutOrIn :: MonadClientUI m => Bool -> m ()
fadeOutOrIn out = do
let topRight = True
lid <- getArenaUI
Level{lxsize, lysize} <- getLevel lid
animMap <- rndToAction $ fadeout out topRight 2 lxsize lysize
animFrs <- animate lid animMap
displayFrames animFrs