{-# 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.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
data FrontReq :: Type -> Type where
FrontFrame :: Frame -> FrontReq ()
FrontDelay :: Int -> FrontReq ()
FrontKey :: [K.KM] -> Frame -> FrontReq KMP
FrontPressed :: FrontReq Bool
FrontDiscardKey :: FrontReq ()
FrontResetKeys :: FrontReq ()
FrontShutdown :: FrontReq ()
FrontPrintScreen :: FrontReq ()
newtype ChanFrontend = ChanFrontend (forall a. FrontReq a -> IO a)
data FrontSetup = FrontSetup
{ FrontSetup -> Async ()
fasyncTimeout :: Async ()
, FrontSetup -> MVar Int
fdelay :: MVar Int
}
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"
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
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
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
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{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
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 ()
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
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
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 Int
0
IO ()
showFrameAndRepeatIfKeys
IO ()
showFrameAndRepeatIfKeys
IO ()
loop
IO ()
loop
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 ()