{-# 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.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           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.Common.ClientOptions
import qualified Game.LambdaHack.Common.PointArray as PointArray
import qualified Game.LambdaHack.Definition.Color as Color

#ifdef USE_BROWSER
import qualified Game.LambdaHack.Client.UI.Frontend.Dom as Chosen
#else
import qualified Game.LambdaHack.Client.UI.Frontend.ANSI as ANSI
import qualified Game.LambdaHack.Client.UI.Frontend.Sdl as Chosen
#endif

-- | 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 single key in the queue, if any.
  FrontDiscardKey :: FrontReq ()
  -- | Discard all keys in the queue.
  FrontResetKeys :: 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 -> 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 ScreenContent
coscreen 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
#ifndef USE_BROWSER
              | ClientOptions -> Bool
sfrontendANSI ClientOptions
soptions = ScreenContent -> IO RawFrontend
ANSI.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 Int
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 Double
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 Text
"Frontend startup up.\n"
      -- hPutStrLn not atomic enough
    Handle -> IO ()
hFlush Handle
stdout
  MVar Int
fdelay <- Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar Int
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 = FrontSetup :: Async () -> MVar Int -> FrontSetup
FrontSetup{Async ()
MVar Int
fasyncTimeout :: Async ()
fdelay :: MVar Int
fdelay :: MVar Int
fasyncTimeout :: Async ()
..}
      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 FrontSetup
fs rf :: RawFrontend
rf@RawFrontend{TQueue KMP
fchanKey :: RawFrontend -> TQueue KMP
fchanKey :: TQueue KMP
fchanKey} [KM]
keys Frame
frame = 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{Async ()
MVar Int
fdelay :: MVar Int
fasyncTimeout :: Async ()
fdelay :: FrontSetup -> MVar Int
fasyncTimeout :: FrontSetup -> Async ()
..} 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 Frame
frontFrame -> RawFrontend -> Frame -> IO ()
display RawFrontend
rf Frame
frontFrame
    FrontDelay Int
k -> 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
+ Int
k)
    FrontKey [KM]
frontKeyKeys Frame
frontKeyFrame ->
      FrontSetup -> RawFrontend -> [KM] -> Frame -> IO KMP
getKey FrontSetup
fs RawFrontend
rf [KM]
frontKeyKeys Frame
frontKeyFrame
    FrontReq a
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
    FrontReq a
FrontDiscardKey ->
      IO (Maybe KMP) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe KMP) -> IO ()) -> IO (Maybe KMP) -> IO ()
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)
    FrontReq a
FrontResetKeys -> TQueue KMP -> IO ()
resetChanKey (RawFrontend -> TQueue KMP
fchanKey RawFrontend
rf)
    FrontReq a
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
    FrontReq a
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}}
        ((FrameBase
m, FrameForall
upd), (OverlaySpace
ovProp, OverlaySpace
ovSquare, 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 -> OverlaySpace -> SingleFrame
SingleFrame Array AttrCharW32
singleArray OverlaySpace
ovProp OverlaySpace
ovSquare OverlaySpace
ovMono

defaultMaxFps :: Double
defaultMaxFps :: Double
defaultMaxFps = Double
24

microInSec :: Int
microInSec :: Int
microInSec = Int
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 Int
delta MVar Int
fdelay RawFrontend{IO ()
MVar ()
TQueue KMP
ScreenContent
SingleFrame -> IO ()
fcoscreen :: ScreenContent
fprintScreen :: IO ()
fchanKey :: TQueue KMP
fshowNow :: MVar ()
fshutdown :: IO ()
fdisplay :: SingleFrame -> IO ()
fdisplay :: RawFrontend -> SingleFrame -> IO ()
fcoscreen :: RawFrontend -> ScreenContent
fprintScreen :: RawFrontend -> IO ()
fshutdown :: RawFrontend -> IO ()
fshowNow :: RawFrontend -> MVar ()
fchanKey :: RawFrontend -> TQueue KMP
..} = 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
> Int
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 Int
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 ClientOptions
soptions =
  if | ClientOptions -> Bool
sfrontendNull ClientOptions
soptions -> String
"null test"
     | ClientOptions -> Bool
sfrontendLazy ClientOptions
soptions -> String
"lazy test"
#ifndef REMOVE_TELETYPE
     | ClientOptions -> Bool
sfrontendTeletype ClientOptions
soptions -> String
Teletype.frontendName
#endif
#ifndef USE_BROWSER
     | ClientOptions -> Bool
sfrontendANSI ClientOptions
soptions -> String
ANSI.frontendName
#endif
     | Bool
otherwise -> String
Chosen.frontendName

lazyStartup :: ScreenContent -> IO RawFrontend
lazyStartup :: ScreenContent -> IO RawFrontend
lazyStartup ScreenContent
coscreen = ScreenContent -> (SingleFrame -> IO ()) -> IO () -> IO RawFrontend
createRawFrontend ScreenContent
coscreen (\SingleFrame
_ -> () -> 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 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{OverlaySpace
Array AttrCharW32
singleMonoOverlay :: SingleFrame -> OverlaySpace
singleSquareOverlay :: SingleFrame -> OverlaySpace
singlePropOverlay :: SingleFrame -> OverlaySpace
singleArray :: SingleFrame -> Array AttrCharW32
singleMonoOverlay :: OverlaySpace
singleSquareOverlay :: OverlaySpace
singlePropOverlay :: OverlaySpace
singleArray :: Array AttrCharW32
..} =
  let seqAttr :: () -> AttrCharW32 -> ()
seqAttr () AttrCharW32
attr = Color -> Text
Color.colorToRGB (AttrCharW32 -> Color
Color.fgFromW32 AttrCharW32
attr)
                        Text -> () -> ()
`seq` AttrCharW32 -> Highlight
Color.bgFromW32 AttrCharW32
attr
                        Highlight -> () -> ()
`seq` AttrCharW32 -> Char
Color.charFromW32 AttrCharW32
attr Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '
                        Bool -> () -> ()
`seq` ()
      !_Force1 :: ()
_Force1 = (() -> AttrCharW32 -> ()) -> () -> Array AttrCharW32 -> ()
forall c a. UnboxRepClass c => (a -> c -> a) -> a -> Array c -> a
PointArray.foldlA' () -> AttrCharW32 -> ()
seqAttr () Array AttrCharW32
singleArray
      !_Force2 :: Int
_Force2 = OverlaySpace -> Int
forall a. [a] -> Int
length OverlaySpace
singlePropOverlay
      !_Force3 :: Int
_Force3 = OverlaySpace -> Int
forall a. [a] -> Int
length OverlaySpace
singleSquareOverlay
      !_Force4 :: Int
_Force4 = OverlaySpace -> Int
forall a. [a] -> Int
length OverlaySpace
singleMonoOverlay
  in () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()