{-# LANGUAGE GADTs, KindSignatures, RankNTypes #-}
-- | Display game data on the screen and receive user input
-- using one of the available raw frontends and derived operations.
module Game.LambdaHack.Client.UI.Frontend
  ( -- * Connection and initialization
    FrontReq(..), ChanFrontend(..), chanFrontendIO
    -- * Re-exported part of the raw frontend
  , frontendName
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , FrontSetup, getKey, fchanFrontend, display, defaultMaxFps, microInSec
  , frameTimeoutThread, lazyStartup, nullStartup, seqFrame
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Control.Concurrent
import           Control.Concurrent.Async
import qualified Control.Concurrent.STM as STM
import           Control.Monad.ST.Strict
import           Data.IORef
import           Data.Kind (Type)
import qualified Data.Text.IO as T
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import           Data.Word
import           System.IO (hFlush, stdout)

import           Game.LambdaHack.Client.UI.Content.Screen
import           Game.LambdaHack.Client.UI.Frame
import qualified Game.LambdaHack.Client.UI.Frontend.Chosen as Chosen
import           Game.LambdaHack.Client.UI.Frontend.Common
import qualified Game.LambdaHack.Client.UI.Frontend.Teletype as Teletype
import           Game.LambdaHack.Client.UI.Key (KMP (..))
import qualified Game.LambdaHack.Client.UI.Key as K
import           Game.LambdaHack.Client.UI.PointUI
import           Game.LambdaHack.Common.ClientOptions
import qualified Game.LambdaHack.Common.PointArray as PointArray
import qualified Game.LambdaHack.Definition.Color as Color

-- | The instructions sent by clients to the raw frontend, indexed
-- by the returned value.
data FrontReq :: Type -> Type where
  -- | Show a frame.
  FrontFrame :: Frame -> FrontReq ()
  -- | Perform an explicit delay of the given length.
  FrontDelay :: Int -> FrontReq ()
  -- | Flush frames, display a frame and ask for a keypress.
  FrontKey :: [K.KM] -> Frame -> FrontReq KMP
  -- | Tell if a keypress is pending.
  FrontPressed :: FrontReq Bool
  -- | Discard a key in the queue, if any.
  FrontDiscardKey :: FrontReq ()
  -- | Discard all keys in the queue.
  FrontResetKeys :: FrontReq ()
  -- | Add a key to the queue.
  FrontAdd :: KMP -> FrontReq ()
  -- | Set in the frontend that it should auto-answer prompts.
  FrontAutoYes :: Bool -> FrontReq ()
  -- | Shut the frontend down.
  FrontShutdown :: FrontReq ()
  -- | Take screenshot.
  FrontPrintScreen :: FrontReq ()

-- | Connection channel between a frontend and a client. Frontend acts
-- as a server, serving keys, etc., when given frames to display.
newtype ChanFrontend = ChanFrontend (forall a. FrontReq a -> IO a)

-- | Machinery allocated for an individual frontend at its startup,
-- unchanged for its lifetime.
data FrontSetup = FrontSetup
  { FrontSetup -> IORef Bool
fautoYesRef   :: IORef Bool
  , FrontSetup -> Async ()
fasyncTimeout :: Async ()
  , FrontSetup -> MVar Int
fdelay        :: MVar Int
  }

-- | Initialize the frontend chosen by the player via client options.
chanFrontendIO :: ScreenContent -> ClientOptions -> IO ChanFrontend
chanFrontendIO :: ScreenContent -> ClientOptions -> IO ChanFrontend
chanFrontendIO coscreen :: ScreenContent
coscreen soptions :: ClientOptions
soptions = do
  let startup :: IO RawFrontend
startup | ClientOptions -> Bool
sfrontendNull ClientOptions
soptions = ScreenContent -> IO RawFrontend
nullStartup ScreenContent
coscreen
              | ClientOptions -> Bool
sfrontendLazy ClientOptions
soptions = ScreenContent -> IO RawFrontend
lazyStartup ScreenContent
coscreen
#ifndef REMOVE_TELETYPE
              | ClientOptions -> Bool
sfrontendTeletype ClientOptions
soptions = ScreenContent -> IO RawFrontend
Teletype.startup ScreenContent
coscreen
#endif
              | Bool
otherwise = ScreenContent -> ClientOptions -> IO RawFrontend
Chosen.startup ScreenContent
coscreen ClientOptions
soptions
      maxFps :: Double
maxFps = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
defaultMaxFps (Maybe Double -> Double) -> Maybe Double -> Double
forall a b. (a -> b) -> a -> b
$ ClientOptions -> Maybe Double
smaxFps ClientOptions
soptions
      delta :: Int
delta = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Double
intToDouble Int
microInSec Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double -> Double -> Double
forall a. Ord a => a -> a -> a
max 0.000001 Double
maxFps
  RawFrontend
rf <- IO RawFrontend
startup
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ClientOptions -> Bool
sdbgMsgCli ClientOptions
soptions) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Handle -> Text -> IO ()
T.hPutStr Handle
stdout "Frontend startup up.\n"
      -- hPutStrLn not atomic enough
    Handle -> IO ()
hFlush Handle
stdout
  IORef Bool
fautoYesRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef (Bool -> IO (IORef Bool)) -> Bool -> IO (IORef Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ClientOptions -> Bool
sdisableAutoYes ClientOptions
soptions
  MVar Int
fdelay <- Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar 0
  Async ()
fasyncTimeout <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Int -> MVar Int -> RawFrontend -> IO ()
frameTimeoutThread Int
delta MVar Int
fdelay RawFrontend
rf
  -- Warning: not linking @fasyncTimeout@, so it'd better not crash.
  let fs :: FrontSetup
fs = $WFrontSetup :: IORef Bool -> Async () -> MVar Int -> FrontSetup
FrontSetup{..}
      chanFrontend :: ChanFrontend
chanFrontend = FrontSetup -> RawFrontend -> ChanFrontend
fchanFrontend FrontSetup
fs RawFrontend
rf
  ChanFrontend -> IO ChanFrontend
forall (m :: * -> *) a. Monad m => a -> m a
return ChanFrontend
chanFrontend

-- Display a frame, wait for any of the specified keys (for any key,
-- if the list is empty). Repeat if an unexpected key received.
getKey :: FrontSetup -> RawFrontend -> [K.KM] -> Frame -> IO KMP
getKey :: FrontSetup -> RawFrontend -> [KM] -> Frame -> IO KMP
getKey fs :: FrontSetup
fs rf :: RawFrontend
rf@RawFrontend{TQueue KMP
fchanKey :: RawFrontend -> TQueue KMP
fchanKey :: TQueue KMP
fchanKey} keys :: [KM]
keys frame :: Frame
frame = do
  Bool
autoYes <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (IORef Bool -> IO Bool) -> IORef Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ FrontSetup -> IORef Bool
fautoYesRef FrontSetup
fs
  if Bool
autoYes Bool -> Bool -> Bool
&& ([KM] -> Bool
forall a. [a] -> Bool
null [KM]
keys Bool -> Bool -> Bool
|| KM
K.spaceKM KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys) then do
    RawFrontend -> Frame -> IO ()
display RawFrontend
rf Frame
frame
    KMP -> IO KMP
forall (m :: * -> *) a. Monad m => a -> m a
return (KMP -> IO KMP) -> KMP -> IO KMP
forall a b. (a -> b) -> a -> b
$! $WKMP :: KM -> PointUI -> KMP
KMP {kmpKeyMod :: KM
kmpKeyMod = KM
K.spaceKM, kmpPointer :: PointUI
kmpPointer = Int -> Int -> PointUI
PointUI 0 0}
  else do
    -- Wait until timeout is up, not to skip the last frame of animation.
    RawFrontend -> Frame -> IO ()
display RawFrontend
rf Frame
frame
    KMP
kmp <- STM KMP -> IO KMP
forall a. STM a -> IO a
STM.atomically (STM KMP -> IO KMP) -> STM KMP -> IO KMP
forall a b. (a -> b) -> a -> b
$ TQueue KMP -> STM KMP
forall a. TQueue a -> STM a
STM.readTQueue TQueue KMP
fchanKey
    if [KM] -> Bool
forall a. [a] -> Bool
null [KM]
keys Bool -> Bool -> Bool
|| KMP -> KM
kmpKeyMod KMP
kmp KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys
    then KMP -> IO KMP
forall (m :: * -> *) a. Monad m => a -> m a
return KMP
kmp
    else FrontSetup -> RawFrontend -> [KM] -> Frame -> IO KMP
getKey FrontSetup
fs RawFrontend
rf [KM]
keys Frame
frame

-- Read UI requests from the client and send them to the frontend,
fchanFrontend :: FrontSetup -> RawFrontend -> ChanFrontend
fchanFrontend :: FrontSetup -> RawFrontend -> ChanFrontend
fchanFrontend fs :: FrontSetup
fs@FrontSetup{..} rf :: RawFrontend
rf =
  (forall a. FrontReq a -> IO a) -> ChanFrontend
ChanFrontend ((forall a. FrontReq a -> IO a) -> ChanFrontend)
-> (forall a. FrontReq a -> IO a) -> ChanFrontend
forall a b. (a -> b) -> a -> b
$ \case
    FrontFrame frontFrame :: Frame
frontFrame -> RawFrontend -> Frame -> IO ()
display RawFrontend
rf Frame
frontFrame
    FrontDelay k :: Int
k -> MVar Int -> (Int -> IO Int) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Int
fdelay ((Int -> IO Int) -> IO a) -> (Int -> IO Int) -> IO a
forall a b. (a -> b) -> a -> b
$ Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> (Int -> Int) -> Int -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k)
    FrontKey frontKeyKeys :: [KM]
frontKeyKeys frontKeyFrame :: Frame
frontKeyFrame ->
      FrontSetup -> RawFrontend -> [KM] -> Frame -> IO KMP
getKey FrontSetup
fs RawFrontend
rf [KM]
frontKeyKeys Frame
frontKeyFrame
    FrontPressed -> do
      Bool
noKeysPending <- STM Bool -> IO Bool
forall a. STM a -> IO a
STM.atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TQueue KMP -> STM Bool
forall a. TQueue a -> STM Bool
STM.isEmptyTQueue (RawFrontend -> TQueue KMP
fchanKey RawFrontend
rf)
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Bool -> Bool
not Bool
noKeysPending
    FrontDiscardKey ->
      IO (Maybe KMP) -> IO a
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe KMP) -> IO a) -> IO (Maybe KMP) -> IO a
forall a b. (a -> b) -> a -> b
$ STM (Maybe KMP) -> IO (Maybe KMP)
forall a. STM a -> IO a
STM.atomically (STM (Maybe KMP) -> IO (Maybe KMP))
-> STM (Maybe KMP) -> IO (Maybe KMP)
forall a b. (a -> b) -> a -> b
$ TQueue KMP -> STM (Maybe KMP)
forall a. TQueue a -> STM (Maybe a)
STM.tryReadTQueue (RawFrontend -> TQueue KMP
fchanKey RawFrontend
rf)
    FrontResetKeys -> TQueue KMP -> IO ()
resetChanKey (RawFrontend -> TQueue KMP
fchanKey RawFrontend
rf)
    FrontAdd kmp :: KMP
kmp -> STM () -> IO a
forall a. STM a -> IO a
STM.atomically (STM () -> IO a) -> STM () -> IO a
forall a b. (a -> b) -> a -> b
$ TQueue KMP -> KMP -> STM ()
forall a. TQueue a -> a -> STM ()
STM.writeTQueue (RawFrontend -> TQueue KMP
fchanKey RawFrontend
rf) KMP
kmp
    FrontAutoYes b :: Bool
b -> IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
fautoYesRef Bool
b
    FrontShutdown -> do
      Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
fasyncTimeout
      -- In case the last frame display is pending:
      IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> IO (Maybe ())
forall a. MVar a -> IO (Maybe a)
tryTakeMVar (MVar () -> IO (Maybe ())) -> MVar () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ RawFrontend -> MVar ()
fshowNow RawFrontend
rf
      RawFrontend -> IO ()
fshutdown RawFrontend
rf
    FrontPrintScreen -> RawFrontend -> IO ()
fprintScreen RawFrontend
rf

display :: RawFrontend -> Frame -> IO ()
display :: RawFrontend -> Frame -> IO ()
display rf :: RawFrontend
rf@RawFrontend{MVar ()
fshowNow :: MVar ()
fshowNow :: RawFrontend -> MVar ()
fshowNow, fcoscreen :: RawFrontend -> ScreenContent
fcoscreen=ScreenContent{Int
rwidth :: ScreenContent -> Int
rwidth :: Int
rwidth, Int
rheight :: ScreenContent -> Int
rheight :: Int
rheight}}
        ((m :: FrameBase
m, upd :: FrameForall
upd), (ovProp :: OverlaySpace
ovProp, ovMono :: OverlaySpace
ovMono)) = do
  let new :: forall s. ST s (G.Mutable U.Vector s Word32)
      new :: ST s (Mutable Vector s Word32)
new = do
        MVector s Word32
v <- FrameBase -> forall s. ST s (Mutable Vector s Word32)
unFrameBase FrameBase
m
        FrameForall -> FrameST s
FrameForall -> forall s. FrameST s
unFrameForall FrameForall
upd MVector s Word32
Mutable Vector s Word32
v
        MVector s Word32 -> ST s (MVector s Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return MVector s Word32
v
      singleArray :: Array AttrCharW32
singleArray = Int -> Int -> Vector (UnboxRep AttrCharW32) -> Array AttrCharW32
forall c. Int -> Int -> Vector (UnboxRep c) -> Array c
PointArray.Array Int
rwidth Int
rheight ((forall s. ST s (MVector s Word32)) -> Vector Word32
forall a. Unbox a => (forall s. ST s (MVector s a)) -> Vector a
U.create forall s. ST s (MVector s Word32)
forall s. ST s (Mutable Vector s Word32)
new)
  MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
fshowNow () -- 1. wait for permission to display; 3. ack
  RawFrontend -> SingleFrame -> IO ()
fdisplay RawFrontend
rf (SingleFrame -> IO ()) -> SingleFrame -> IO ()
forall a b. (a -> b) -> a -> b
$ Array AttrCharW32 -> OverlaySpace -> OverlaySpace -> SingleFrame
SingleFrame Array AttrCharW32
singleArray OverlaySpace
ovProp OverlaySpace
ovMono

defaultMaxFps :: Double
defaultMaxFps :: Double
defaultMaxFps = 24

microInSec :: Int
microInSec :: Int
microInSec = 1000000

-- This thread is canceled forcefully, because the @threadDelay@
-- may be much longer than an acceptable shutdown time.
frameTimeoutThread :: Int -> MVar Int -> RawFrontend -> IO ()
frameTimeoutThread :: Int -> MVar Int -> RawFrontend -> IO ()
frameTimeoutThread delta :: Int
delta fdelay :: MVar Int
fdelay RawFrontend{..} = do
  let loop :: IO ()
loop = do
        Int -> IO ()
threadDelay Int
delta
        let delayLoop :: IO ()
delayLoop = do
              Int
delay <- MVar Int -> IO Int
forall a. MVar a -> IO a
readMVar MVar Int
fdelay
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
delay Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
delta Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
delay
                MVar Int -> (Int -> IO Int) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Int
fdelay ((Int -> IO Int) -> IO ()) -> (Int -> IO Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> (Int -> Int) -> Int -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
delay
                IO ()
delayLoop
        IO ()
delayLoop
        let showFrameAndRepeatIfKeys :: IO ()
showFrameAndRepeatIfKeys = do
              -- @fshowNow@ is full at this point, unless @saveKM@ emptied it,
              -- in which case we wait below until @display@ fills it
              MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
fshowNow  -- 2. permit display
              -- @fshowNow@ is ever empty only here, unless @saveKM@ empties it
              MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
fshowNow  -- 4. wait for ack before starting delay
              -- @fshowNow@ is full at this point
              Bool
noKeysPending <- STM Bool -> IO Bool
forall a. STM a -> IO a
STM.atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TQueue KMP -> STM Bool
forall a. TQueue a -> STM Bool
STM.isEmptyTQueue TQueue KMP
fchanKey
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
noKeysPending (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar Int -> Int -> IO Int
forall a. MVar a -> a -> IO a
swapMVar MVar Int
fdelay 0  -- cancel delays lest they accumulate
                IO ()
showFrameAndRepeatIfKeys
        IO ()
showFrameAndRepeatIfKeys
        IO ()
loop
  IO ()
loop

-- | The name of the chosen frontend.
frontendName :: ClientOptions -> String
frontendName :: ClientOptions -> String
frontendName soptions :: ClientOptions
soptions =
  if | ClientOptions -> Bool
sfrontendNull ClientOptions
soptions -> "null test"
     | ClientOptions -> Bool
sfrontendLazy ClientOptions
soptions -> "lazy test"
#ifndef REMOVE_TELETYPE
     | ClientOptions -> Bool
sfrontendTeletype ClientOptions
soptions -> String
Teletype.frontendName
#endif
     | Bool
otherwise -> String
Chosen.frontendName

lazyStartup :: ScreenContent -> IO RawFrontend
lazyStartup :: ScreenContent -> IO RawFrontend
lazyStartup coscreen :: ScreenContent
coscreen = ScreenContent -> (SingleFrame -> IO ()) -> IO () -> IO RawFrontend
createRawFrontend ScreenContent
coscreen (\_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

nullStartup :: ScreenContent -> IO RawFrontend
nullStartup :: ScreenContent -> IO RawFrontend
nullStartup coscreen :: ScreenContent
coscreen = ScreenContent -> (SingleFrame -> IO ()) -> IO () -> IO RawFrontend
createRawFrontend ScreenContent
coscreen SingleFrame -> IO ()
seqFrame (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

seqFrame :: SingleFrame -> IO ()
seqFrame :: SingleFrame -> IO ()
seqFrame SingleFrame{Array AttrCharW32
singleArray :: SingleFrame -> Array AttrCharW32
singleArray :: Array AttrCharW32
singleArray} =
  let seqAttr :: () -> AttrCharW32 -> ()
seqAttr () attr :: AttrCharW32
attr = Color -> Text
Color.colorToRGB (AttrCharW32 -> Color
Color.fgFromW32 AttrCharW32
attr)
                        Text -> () -> ()
forall a b. a -> b -> b
`seq` AttrCharW32 -> Highlight
Color.bgFromW32 AttrCharW32
attr
                        Highlight -> () -> ()
forall a b. a -> b -> b
`seq` AttrCharW32 -> Char
Color.charFromW32 AttrCharW32
attr Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' '
                        Bool -> () -> ()
forall a b. a -> b -> b
`seq` ()
  in () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$! (() -> AttrCharW32 -> ()) -> () -> Array AttrCharW32 -> ()
forall c a. UnboxRepClass c => (a -> c -> a) -> a -> Array c -> a
PointArray.foldlA' () -> AttrCharW32 -> ()
seqAttr () Array AttrCharW32
singleArray