module Game.LambdaHack.Client.UI.MonadClientUI
(
MonadClientUI( getsSession
, liftIO
)
, SessionUI(..)
, ColorMode(..)
, promptGetKey, getKeyOverlayCommand, getInitConfirms
, displayFrame, displayDelay, displayActorStart, drawOverlay
, stopPlayBack, askConfig, askBinding
, syncFrames, setFrontAutoYes, tryTakeMVarSescMVar, scoreToSlideshow
, getLeaderUI, getArenaUI, viewedLevel
, targetDescLeader, targetDescCursor
, leaderTgtToPos, leaderTgtAims, cursorToPos
) where
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified NLP.Miniutter.English as MU
import System.Time
import Game.LambdaHack.Client.BfsClient
import Game.LambdaHack.Client.CommonClient
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.Config
import Game.LambdaHack.Client.UI.DrawClient
import Game.LambdaHack.Client.UI.Frontend as Frontend
import Game.LambdaHack.Client.UI.KeyBindings
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.HighScore as HighScore
import Game.LambdaHack.Common.ItemDescription
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.State
import Game.LambdaHack.Common.Time
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind
data SessionUI = SessionUI
{ schanF :: !ChanFrontend
, sbinding :: !Binding
, sescMVar :: !(Maybe (MVar ()))
, sconfig :: !Config
}
class MonadClient m => MonadClientUI m where
getsSession :: (SessionUI -> a) -> m a
liftIO :: IO a -> m a
readConnFrontend :: MonadClientUI m => m K.KM
readConnFrontend = do
ChanFrontend{responseF} <- getsSession schanF
liftIO $ atomically $ readTQueue responseF
writeConnFrontend :: MonadClientUI m => FrontReq -> m ()
writeConnFrontend efr = do
ChanFrontend{requestF} <- getsSession schanF
liftIO $ atomically $ writeTQueue requestF efr
promptGetKey :: MonadClientUI m => [K.KM] -> SingleFrame -> m K.KM
promptGetKey frontKM frontFr = do
arena <- getArenaUI
localTime <- getsState $ getLocalTime arena
let ageDisp = EM.insert arena localTime
modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli}
escPressed <- tryTakeMVarSescMVar
lastPlayOld <- getsClient slastPlay
km <- case lastPlayOld of
km : kms | not escPressed && (null frontKM || km `elem` frontKM) -> do
displayFrame $ Just frontFr
syncFrames
modifyClient $ \cli -> cli {slastPlay = kms}
return km
_ -> do
stopPlayBack
writeConnFrontend FrontKey{..}
km <- readConnFrontend
modifyClient $ \cli -> cli {slastKM = km}
return km
(seqCurrent, seqPrevious, k) <- getsClient slastRecord
let slastRecord = (km : seqCurrent, seqPrevious, k)
modifyClient $ \cli -> cli {slastRecord}
return km
getKeyOverlayCommand :: MonadClientUI m => Maybe Bool -> Overlay -> m K.KM
getKeyOverlayCommand onBlank overlay = do
frame <- drawOverlay (isJust onBlank) ColorFull overlay
promptGetKey [] frame
getInitConfirms :: MonadClientUI m
=> ColorMode -> [K.KM] -> Slideshow -> m Bool
getInitConfirms dm frontClear slides = do
let (onBlank, ovs) = slideshow slides
frontFromTop = onBlank
frontSlides <- drawOverlays (isJust onBlank) dm ovs
case frontSlides of
[] -> return True
_ -> do
writeConnFrontend FrontSlides{..}
km <- readConnFrontend
return $! km /= K.escKM
displayFrame :: MonadClientUI m => Maybe SingleFrame -> m ()
displayFrame mf = do
let frame = case mf of
Nothing -> FrontDelay
Just fr -> FrontNormalFrame fr
writeConnFrontend frame
displayDelay :: MonadClientUI m => m ()
displayDelay = sequence_ $ replicate 4 $ writeConnFrontend FrontDelay
displayActorStart :: MonadClientUI m => Actor -> Frames -> m ()
displayActorStart b frs = do
timeCutOff <- getsClient $ EM.findWithDefault timeZero (blid b) . sdisplayed
localTime <- getsState $ getLocalTime (blid b)
let delta = localTime `timeDeltaToFrom` timeCutOff
when (delta > Delta timeClip && not (bproj b))
displayDelay
let ageDisp = EM.insert (blid b) localTime
modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli}
mapM_ displayFrame frs
drawOverlay :: MonadClientUI m
=> Bool -> ColorMode -> Overlay -> m SingleFrame
drawOverlay sfBlank@True _ sfTop = do
let sfLevel = []
sfBottom = []
return $! SingleFrame {..}
drawOverlay False dm sfTop = do
lid <- viewedLevel
mleader <- getsClient _sleader
tgtPos <- leaderTgtToPos
cursorPos <- cursorToPos
let anyPos = fromMaybe (Point 0 0) cursorPos
pathFromLeader leader = Just <$> getCacheBfsAndPath leader anyPos
bfsmpath <- maybe (return Nothing) pathFromLeader mleader
tgtDesc <- maybe (return ("------", Nothing)) targetDescLeader mleader
cursorDesc <- targetDescCursor
draw dm lid cursorPos tgtPos bfsmpath cursorDesc tgtDesc sfTop
drawOverlays :: MonadClientUI m
=> Bool -> ColorMode -> [Overlay] -> m [SingleFrame]
drawOverlays _ _ [] = return []
drawOverlays sfBlank dm (topFirst : rest) = do
fistFrame <- drawOverlay sfBlank dm topFirst
let f topNext = fistFrame {sfTop = topNext}
return $! fistFrame : map f rest
stopPlayBack :: MonadClientUI m => m ()
stopPlayBack = do
modifyClient $ \cli -> cli
{ slastPlay = []
, slastRecord = let (seqCurrent, seqPrevious, _) = slastRecord cli
in (seqCurrent, seqPrevious, 0)
, swaitTimes = abs (swaitTimes cli)
}
srunning <- getsClient srunning
case srunning of
Nothing -> return ()
Just RunParams{runLeader} -> do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
arena <- getArenaUI
s <- getState
when (memActor runLeader arena s && not (noRunWithMulti fact)) $
modifyClient $ updateLeader runLeader s
modifyClient (\cli -> cli {srunning = Nothing})
askConfig :: MonadClientUI m => m Config
askConfig = getsSession sconfig
askBinding :: MonadClientUI m => m Binding
askBinding = getsSession sbinding
syncFrames :: MonadClientUI m => m ()
syncFrames = do
writeConnFrontend
FrontSlides{frontClear=[], frontSlides=[], frontFromTop=Nothing}
km <- readConnFrontend
let !_A = assert (km == K.spaceKM) ()
return ()
setFrontAutoYes :: MonadClientUI m => Bool -> m ()
setFrontAutoYes b = writeConnFrontend $ FrontAutoYes b
tryTakeMVarSescMVar :: MonadClientUI m => m Bool
tryTakeMVarSescMVar = do
mescMVar <- getsSession sescMVar
case mescMVar of
Nothing -> return False
Just escMVar -> do
mUnit <- liftIO $ tryTakeMVar escMVar
return $! isJust mUnit
scoreToSlideshow :: MonadClientUI m => Int -> Status -> m Slideshow
scoreToSlideshow total status = do
fid <- getsClient sside
fact <- getsState $ (EM.! fid) . sfactionD
scoreDict <- getsState shigh
gameModeId <- getsState sgameModeId
gameMode <- getGameMode
time <- getsState stime
date <- liftIO getClockTime
scurDifficulty <- getsClient scurDifficulty
factionD <- getsState sfactionD
let table = HighScore.getTable gameModeId scoreDict
gameModeName = mname gameMode
showScore (ntable, pos) =
HighScore.highSlideshow ntable pos gameModeName
diff | not $ fhasUI $ gplayer fact = difficultyDefault
| otherwise = scurDifficulty
theirVic (fi, fa) | isAtWar fact fi
&& not (isHorrorFact fa) = Just $ gvictims fa
| otherwise = Nothing
theirVictims = EM.unionsWith (+) $ mapMaybe theirVic $ EM.assocs factionD
ourVic (fi, fa) | isAllied fact fi || fi == fid = Just $ gvictims fa
| otherwise = Nothing
ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD
(worthMentioning, rScore) =
HighScore.register table total time status date diff
(fname $ gplayer fact)
ourVictims theirVictims
(fhiCondPoly $ gplayer fact)
return $! if worthMentioning then showScore rScore else mempty
getLeaderUI :: MonadClientUI m => m ActorId
getLeaderUI = do
cli <- getClient
case _sleader cli of
Nothing -> assert `failure` "leader expected but not found" `twith` cli
Just leader -> return leader
getArenaUI :: MonadClientUI m => m LevelId
getArenaUI = do
mleader <- getsClient _sleader
case mleader of
Just leader -> getsState $ blid . getActorBody leader
Nothing -> do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
case gquit fact of
Just Status{stDepth} -> return $! toEnum stDepth
Nothing -> do
dungeon <- getsState sdungeon
let (minD, maxD) =
case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of
(Just ((s, _), _), Just ((e, _), _)) -> (s, e)
_ -> assert `failure` "empty dungeon" `twith` dungeon
return $! max minD $ min maxD $ toEnum $ fentryLevel $ gplayer fact
viewedLevel :: MonadClientUI m => m LevelId
viewedLevel = do
arena <- getArenaUI
stgtMode <- getsClient stgtMode
return $! maybe arena tgtLevelId stgtMode
targetDesc :: MonadClientUI m => Maybe Target -> m (Text, Maybe Text)
targetDesc target = do
lidV <- viewedLevel
mleader <- getsClient _sleader
case target of
Just (TEnemy aid _) -> do
side <- getsClient sside
b <- getsState $ getActorBody aid
maxHP <- sumOrganEqpClient IK.EqpSlotAddMaxHP aid
let percentage = 100 * bhp b `div` xM (max 5 maxHP)
stars | percentage < 20 = "[_____]"
| percentage < 40 = "[*____]"
| percentage < 60 = "[**___]"
| percentage < 80 = "[***__]"
| percentage < 100 = "[****_]"
| otherwise = "[*****]"
hpIndicator = if bfid b == side then Nothing else Just stars
return (bname b, hpIndicator)
Just (TEnemyPos _ lid p _) -> do
let hotText = if lid == lidV
then "hot spot" <+> tshow p
else "a hot spot on level" <+> tshow (abs $ fromEnum lid)
return (hotText, Nothing)
Just (TPoint lid p) -> do
pointedText <-
if lid == lidV
then do
bag <- getsState $ getCBag (CFloor lid p)
case EM.assocs bag of
[] -> return $! "exact spot" <+> tshow p
[(iid, kit@(k, _))] -> do
localTime <- getsState $ getLocalTime lid
itemToF <- itemToFullClient
let (_, name, stats) = partItem CGround lid localTime (itemToF iid kit)
return $! makePhrase $ if k == 1
then [name, stats]
else [MU.CarWs k name, stats]
_ -> return $! "many items at" <+> tshow p
else return $! "an exact spot on level" <+> tshow (abs $ fromEnum lid)
return (pointedText, Nothing)
Just TVector{} ->
case mleader of
Nothing -> return ("a relative shift", Nothing)
Just aid -> do
tgtPos <- aidTgtToPos aid lidV target
let invalidMsg = "an invalid relative shift"
validMsg p = "shift to" <+> tshow p
return (maybe invalidMsg validMsg tgtPos, Nothing)
Nothing -> return ("crosshair location", Nothing)
targetDescLeader :: MonadClientUI m => ActorId -> m (Text, Maybe Text)
targetDescLeader leader = do
tgt <- getsClient $ getTarget leader
targetDesc tgt
targetDescCursor :: MonadClientUI m => m (Text, Maybe Text)
targetDescCursor = do
scursor <- getsClient scursor
targetDesc $ Just scursor
leaderTgtToPos :: MonadClientUI m => m (Maybe Point)
leaderTgtToPos = do
lidV <- viewedLevel
mleader <- getsClient _sleader
case mleader of
Nothing -> return Nothing
Just aid -> do
tgt <- getsClient $ getTarget aid
aidTgtToPos aid lidV tgt
leaderTgtAims :: MonadClientUI m => m (Either Text Int)
leaderTgtAims = do
lidV <- viewedLevel
mleader <- getsClient _sleader
case mleader of
Nothing -> return $ Left "no leader to target with"
Just aid -> do
tgt <- getsClient $ getTarget aid
aidTgtAims aid lidV tgt
cursorToPos :: MonadClientUI m => m (Maybe Point)
cursorToPos = do
lidV <- viewedLevel
mleader <- getsClient _sleader
scursor <- getsClient scursor
case mleader of
Nothing -> return Nothing
Just aid -> aidTgtToPos aid lidV $ Just scursor