1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
|
{-# 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
{ fasyncTimeout :: Async ()
, fdelay :: MVar Int
}
-- | Initialize the frontend chosen by the player via client options.
chanFrontendIO :: ScreenContent -> ClientOptions -> IO ChanFrontend
chanFrontendIO coscreen soptions = do
let startup | sfrontendNull soptions = nullStartup coscreen
| sfrontendLazy soptions = lazyStartup coscreen
#ifndef REMOVE_TELETYPE
| sfrontendTeletype soptions = Teletype.startup coscreen
#endif
#ifndef USE_BROWSER
| sfrontendANSI soptions = ANSI.startup coscreen
#endif
| otherwise = Chosen.startup coscreen soptions
maxFps = fromMaybe defaultMaxFps $ smaxFps soptions
delta = max 1 $ round $ intToDouble microInSec / max 0.000001 maxFps
rf <- startup
when (sdbgMsgCli soptions) $ do
T.hPutStr stdout "Frontend startup up.\n"
-- hPutStrLn not atomic enough
hFlush stdout
fdelay <- newMVar 0
fasyncTimeout <- async $ frameTimeoutThread delta fdelay rf
-- Warning: not linking @fasyncTimeout@, so it'd better not crash.
let fs = FrontSetup{..}
chanFrontend = fchanFrontend fs rf
return 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 fs rf@RawFrontend{fchanKey} keys frame = do
-- Wait until timeout is up, not to skip the last frame of animation.
display rf frame
kmp <- STM.atomically $ STM.readTQueue fchanKey
if null keys || kmpKeyMod kmp `elem` keys
then return kmp
else getKey fs rf keys frame
-- Read UI requests from the client and send them to the frontend,
fchanFrontend :: FrontSetup -> RawFrontend -> ChanFrontend
fchanFrontend fs@FrontSetup{..} rf =
ChanFrontend $ \case
FrontFrame frontFrame -> display rf frontFrame
FrontDelay k -> modifyMVar_ fdelay $ return . (+ k)
FrontKey frontKeyKeys frontKeyFrame ->
getKey fs rf frontKeyKeys frontKeyFrame
FrontPressed -> do
noKeysPending <- STM.atomically $ STM.isEmptyTQueue (fchanKey rf)
return $! not noKeysPending
FrontDiscardKey ->
void $ STM.atomically $ STM.tryReadTQueue (fchanKey rf)
FrontResetKeys -> resetChanKey (fchanKey rf)
FrontShutdown -> do
cancel fasyncTimeout
-- In case the last frame display is pending:
void $ tryTakeMVar $ fshowNow rf
fshutdown rf
FrontPrintScreen -> fprintScreen rf
display :: RawFrontend -> Frame -> IO ()
display rf@RawFrontend{fshowNow, fcoscreen=ScreenContent{rwidth, rheight}}
((m, upd), (ovProp, ovSquare, ovMono)) = do
let new :: forall s. ST s (G.Mutable U.Vector s Word32)
new = do
v <- unFrameBase m
unFrameForall upd v
return v
singleArray = PointArray.Array rwidth rheight (U.create new)
putMVar fshowNow () -- 1. wait for permission to display; 3. ack
fdisplay rf $ SingleFrame singleArray ovProp ovSquare ovMono
defaultMaxFps :: Double
defaultMaxFps = 24
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 delta fdelay RawFrontend{..} = do
let loop = do
threadDelay delta
let delayLoop = do
delay <- readMVar fdelay
when (delay > 0) $ do
threadDelay $ delta * delay
modifyMVar_ fdelay $ return . subtract delay
delayLoop
delayLoop
let showFrameAndRepeatIfKeys = do
-- @fshowNow@ is full at this point, unless @saveKM@ emptied it,
-- in which case we wait below until @display@ fills it
takeMVar fshowNow -- 2. permit display
-- @fshowNow@ is ever empty only here, unless @saveKM@ empties it
readMVar fshowNow -- 4. wait for ack before starting delay
-- @fshowNow@ is full at this point
noKeysPending <- STM.atomically $ STM.isEmptyTQueue fchanKey
unless noKeysPending $ do
void $ swapMVar fdelay 0 -- cancel delays lest they accumulate
showFrameAndRepeatIfKeys
showFrameAndRepeatIfKeys
loop
loop
-- | The name of the chosen frontend.
frontendName :: ClientOptions -> String
frontendName soptions =
if | sfrontendNull soptions -> "null test"
| sfrontendLazy soptions -> "lazy test"
#ifndef REMOVE_TELETYPE
| sfrontendTeletype soptions -> Teletype.frontendName
#endif
#ifndef USE_BROWSER
| sfrontendANSI soptions -> ANSI.frontendName
#endif
| otherwise -> Chosen.frontendName
lazyStartup :: ScreenContent -> IO RawFrontend
lazyStartup coscreen = createRawFrontend coscreen (\_ -> return ()) (return ())
nullStartup :: ScreenContent -> IO RawFrontend
nullStartup coscreen = createRawFrontend coscreen seqFrame (return ())
seqFrame :: SingleFrame -> IO ()
seqFrame SingleFrame{..} =
let seqAttr () attr = Color.colorToRGB (Color.fgFromW32 attr)
`seq` Color.bgFromW32 attr
`seq` Color.charFromW32 attr == ' '
`seq` ()
!_Force1 = PointArray.foldlA' seqAttr () singleArray
!_Force2 = length singlePropOverlay
!_Force3 = length singleSquareOverlay
!_Force4 = length singleMonoOverlay
in return ()
|
