{-# LANGUAGE GADTs, KindSignatures, RankNTypes #-}
module Game.LambdaHack.Client.UI.Frontend
(
FrontReq(..), ChanFrontend(..), chanFrontendIO
, frontendName
#ifdef EXPOSE_INTERNAL
, 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
data FrontReq :: Type -> Type where
FrontFrame :: Frame -> FrontReq ()
FrontDelay :: Int -> FrontReq ()
FrontKey :: [K.KM] -> Frame -> FrontReq KMP
FrontPressed :: FrontReq Bool
FrontDiscardKey :: FrontReq ()
FrontResetKeys :: FrontReq ()
FrontAdd :: KMP -> FrontReq ()
FrontAutoYes :: Bool -> FrontReq ()
FrontShutdown :: FrontReq ()
FrontPrintScreen :: FrontReq ()
newtype ChanFrontend = ChanFrontend (forall a. FrontReq a -> IO a)
data FrontSetup = FrontSetup
{ FrontSetup -> IORef Bool
fautoYesRef :: IORef Bool
, FrontSetup -> Async ()
fasyncTimeout :: Async ()
, FrontSetup -> MVar Int
fdelay :: MVar Int
}
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"
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
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
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
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
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
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 ()
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
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
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
fshowNow
MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
fshowNow
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
IO ()
showFrameAndRepeatIfKeys
IO ()
showFrameAndRepeatIfKeys
IO ()
loop
IO ()
loop
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