module Game.LambdaHack.Frontend
(
frontendName
, startupF
, ChanFrontend, FrontReq(..), ConnMulti(..), connMulti
) where
import Control.Concurrent
import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, writeTQueue)
import qualified Control.Concurrent.STM as STM
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import Game.LambdaHack.Common.Animation
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.Key as K
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Frontend.Chosen
import Game.LambdaHack.Utils.LQueue
import Game.LambdaHack.Utils.Thread
type ChanFrontend = TQueue K.KM
type FromMulti = MVar (Int, FactionId -> (ChanFrontend, Text))
type ToMulti = TQueue (FactionId, FrontReq)
data FrontReq =
FrontFrame {frontAc :: !AcFrame}
| FrontKey {frontKM :: ![K.KM], frontFr :: !SingleFrame}
| FrontSlides {frontClear :: ![K.KM], frontSlides :: ![SingleFrame]}
| FrontFinish
type ReqMap = EM.EnumMap FactionId (LQueue AcFrame)
data ConnMulti = ConnMulti
{ fromMulti :: !FromMulti
, toMulti :: !ToMulti
}
startupF :: DebugModeCli -> IO () -> IO ()
startupF dbg cont =
(if sfrontendNo dbg then noStartup
else if sfrontendStd dbg then stdStartup
else chosenStartup) dbg $ \fs -> do
let debugPrint t = when (sdbgMsgCli dbg) $ do
T.hPutStrLn stderr t
hFlush stderr
children <- newMVar []
void $ forkChild children $ loopFrontend fs connMulti
cont
debugPrint "Server shuts down"
let toF = toMulti connMulti
atomically $ writeTQueue toF (toEnum 0 , FrontFinish)
waitForChildren children
debugPrint "Frontend shuts down"
promptGetKey :: Frontend -> [K.KM] -> SingleFrame -> IO K.KM
promptGetKey fs [] frame = fpromptGetKey fs frame
promptGetKey fs keys@(firstKM:_) frame = do
km <- fpromptGetKey fs frame
if km `elem` keys
then return $! km
else do
let DebugModeCli{snoMore} = fdebugCli fs
if snoMore then return firstKM
else promptGetKey fs keys frame
connMulti :: ConnMulti
connMulti = unsafePerformIO $ do
fromMulti <- newMVar undefined
toMulti <- newTQueueIO
return $! ConnMulti{..}
getConfirmGeneric :: Monad m
=> ([K.KM] -> a -> m K.KM)
-> [K.KM] -> a -> m Bool
getConfirmGeneric pGetKey clearKeys x = do
let extraKeys = [ K.KM {key=K.Space, modifier=K.NoModifier}
, K.escKey ]
km <- pGetKey (clearKeys ++ extraKeys) x
return $! km /= K.escKey
flushFrames :: Frontend -> FactionId -> ReqMap -> IO ReqMap
flushFrames fs fid reqMap = do
let queue = toListLQueue $ fromMaybe newLQueue $ EM.lookup fid reqMap
reqMap2 = EM.delete fid reqMap
mapM_ (displayAc fs) queue
return $! reqMap2
displayAc :: Frontend -> AcFrame -> IO ()
displayAc fs (AcConfirm fr) = void $ getConfirmGeneric (promptGetKey fs) [] fr
displayAc fs (AcRunning fr) = fdisplay fs True (Just fr)
displayAc fs (AcNormal fr) = fdisplay fs False (Just fr)
displayAc fs AcDelay = fdisplay fs False Nothing
getSingleFrame :: AcFrame -> Maybe SingleFrame
getSingleFrame (AcConfirm fr) = Just fr
getSingleFrame (AcRunning fr) = Just fr
getSingleFrame (AcNormal fr) = Just fr
getSingleFrame AcDelay = Nothing
toSingles :: FactionId -> ReqMap -> [SingleFrame]
toSingles fid reqMap =
let queue = toListLQueue $ fromMaybe newLQueue $ EM.lookup fid reqMap
in mapMaybe getSingleFrame queue
fadeF :: Frontend -> Bool -> FactionId -> Text -> SingleFrame -> IO ()
fadeF fs out side pname frame = do
let topRight = True
lxsize = xsizeSingleFrame frame
lysize = ysizeSingleFrame frame
msg = "Player" <+> tshow (fromEnum side) <> ","
<+> pname <> (if T.null pname then "" else ",")
<+> "get ready!"
animMap <- rndToIO $ fadeout out topRight lxsize lysize
let sfTop = truncateToOverlay lxsize msg
basicFrame = frame {sfTop}
animFrs = renderAnim lxsize lysize basicFrame animMap
frs | out = animFrs
| otherwise = animFrs ++ [Nothing]
mapM_ (fdisplay fs False) frs
insertFr :: FactionId -> AcFrame -> ReqMap -> ReqMap
insertFr fid fr reqMap =
let queue = fromMaybe newLQueue $ EM.lookup fid reqMap
in EM.insert fid (writeLQueue queue fr) reqMap
loopFrontend :: Frontend -> ConnMulti -> IO ()
loopFrontend fs ConnMulti{..} = loop Nothing EM.empty
where
writeKM :: FactionId -> K.KM -> IO ()
writeKM fid km = do
fM <- takeMVar fromMulti
let chanFrontend = fst $ snd fM fid
atomically $ STM.writeTQueue chanFrontend km
putMVar fromMulti fM
flushFade :: SingleFrame -> Maybe (FactionId, SingleFrame)
-> ReqMap -> FactionId
-> IO ReqMap
flushFade frontFr oldFidFrame reqMap fid =
if Just fid == fmap fst oldFidFrame then
return reqMap
else do
(nU, fCT) <- readMVar fromMulti
let pname = snd $ fCT fid
reqMap2 <- case oldFidFrame of
Nothing -> return reqMap
Just (oldFid, oldFrame) -> do
reqMap2 <- flushFrames fs oldFid reqMap
let singles = toSingles oldFid reqMap
lastFrame = fromMaybe oldFrame $ listToMaybe $ reverse singles
fadeF fs True fid pname lastFrame
return $! reqMap2
let singles = toSingles fid reqMap2
firstFrame = fromMaybe frontFr $ listToMaybe singles
unless (isNothing oldFidFrame && nU < 2) $
fadeF fs False fid pname firstFrame
flushFrames fs fid reqMap2
loop :: Maybe (FactionId, SingleFrame) -> ReqMap -> IO ()
loop oldFidFrame reqMap = do
(fid, efr) <- atomically $ STM.readTQueue toMulti
case efr of
FrontFrame{..} | Just (oldFid, oldFrame) <- oldFidFrame
, fid == oldFid -> do
displayAc fs frontAc
let frame = fromMaybe oldFrame $ getSingleFrame frontAc
loop (Just (fid, frame)) reqMap
FrontFrame{..} -> do
let reqMap2 = insertFr fid frontAc reqMap
loop oldFidFrame reqMap2
FrontKey{..} -> do
reqMap2 <- flushFade frontFr oldFidFrame reqMap fid
km <- promptGetKey fs frontKM frontFr
writeKM fid km
loop (Just (fid, frontFr)) reqMap2
FrontSlides{frontSlides = []} -> return ()
FrontSlides{frontSlides = frontSlides@(fr1 : _), ..} -> do
reqMap2 <- flushFade fr1 oldFidFrame reqMap fid
let displayFrs frs =
case frs of
[] -> assert `failure` "null slides" `twith` fid
[x] -> do
fdisplay fs False (Just x)
writeKM fid K.KM {key=K.Space, modifier=K.NoModifier}
return x
x : xs -> do
go <- getConfirmGeneric (promptGetKey fs) frontClear x
if go then displayFrs xs
else do
writeKM fid K.escKey
return x
frLast <- displayFrs frontSlides
loop (Just (fid, frLast)) reqMap2
FrontFinish ->
return ()