/
Sdl.hs
546 lines (526 loc) · 24.5 KB
/
Sdl.hs
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
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
-- | Text frontend based on SDL2.
module Game.LambdaHack.Client.UI.Frontend.Sdl
( startup, frontendName
#ifdef EXPOSE_INTERNAL
-- * Internal operations
, FontAtlas, FrontendSession(..), startupFun, shutdown, forceShutdown
, display, drawFrame, printScreen, modTranslate, keyTranslate, colorToRGBA
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Control.Concurrent
import qualified Data.Char as Char
import qualified Data.EnumMap.Strict as EM
import Data.IORef
import qualified Data.Text as T
import Data.Time.Clock.POSIX
import Data.Time.LocalTime
import qualified Data.Vector.Unboxed as U
import Data.Word (Word32, Word8)
import Foreign.C.String (withCString)
import Foreign.C.Types (CInt)
import Foreign.Ptr (nullPtr)
import Foreign.Storable (peek)
import System.Directory
import System.Exit (exitSuccess)
import System.FilePath
import qualified SDL
import qualified SDL.Font as TTF
import SDL.Input.Keyboard.Codes
import qualified SDL.Internal.Types
import qualified SDL.Raw.Basic as SDL (logSetAllPriority)
import qualified SDL.Raw.Enum
import qualified SDL.Raw.Types
import qualified SDL.Raw.Video
import qualified SDL.Vect as Vect
import Game.LambdaHack.Client.ClientOptions
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.Key as K
import Game.LambdaHack.Common.File
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Content.TileKind (floorSymbol)
import qualified Game.LambdaHack.Definition.Color as Color
type FontAtlas = EM.EnumMap Color.AttrCharW32 SDL.Texture
-- | Session data maintained by the frontend.
data FrontendSession = FrontendSession
{ swindow :: SDL.Window
, srenderer :: SDL.Renderer
, sfont :: TTF.Font
, satlas :: IORef FontAtlas
, stexture :: IORef SDL.Texture
, spreviousFrame :: IORef SingleFrame
, sforcedShutdown :: IORef Bool
, scontinueSdlLoop :: IORef Bool
, sframeQueue :: MVar SingleFrame
, sframeDrawn :: MVar ()
}
-- | The name of the frontend.
frontendName :: String
frontendName = "sdl"
-- | Set up and start the main loop providing input and output.
--
-- Because of Windows and OS X, SDL2 needs to be on a bound thread,
-- so we can't avoid the communication overhead of bound threads.
startup :: ScreenContent -> ClientOptions -> IO RawFrontend
startup coscreen soptions = startupBound $ startupFun coscreen soptions
startupFun :: ScreenContent -> ClientOptions -> MVar RawFrontend -> IO ()
startupFun coscreen soptions@ClientOptions{..} rfMVar = do
SDL.initialize [SDL.InitEvents]
-- lowest: pattern SDL_LOG_PRIORITY_VERBOSE = (1) :: LogPriority
-- our default: pattern SDL_LOG_PRIORITY_ERROR = (5) :: LogPriority
SDL.logSetAllPriority $ toEnum $ fromMaybe 5 slogPriority
let title = fromJust stitle
fontFileName = T.unpack (fromJust sdlFontFile)
fontFileOrig | isRelative fontFileName = fromJust sfontDir </> fontFileName
| otherwise = fontFileName
(fontFileExists, fontFile) <- do
fontFileOrigExists <- doesFileExist fontFileOrig
if fontFileOrigExists
then return (True, fontFileOrig)
else do
-- Handling old font format specified in old game config files.
let fontFileAlt = dropExtension fontFileOrig <.> "fnt"
fontFileAltExists <- doesFileExist fontFileAlt
return (fontFileAltExists, fontFileAlt)
unless fontFileExists $
fail $ "Font file does not exist: " ++ fontFileOrig
let fontSize = fromJust sscalableFontSize -- will be ignored for bitmap fonts
TTF.initialize
sfont <- TTF.load fontFile fontSize
let isBitmapFile = "fon" `isSuffixOf` T.unpack (fromJust sdlFontFile)
|| "fnt" `isSuffixOf` T.unpack (fromJust sdlFontFile)
|| "bdf" `isSuffixOf` T.unpack (fromJust sdlFontFile)
|| "FON" `isSuffixOf` T.unpack (fromJust sdlFontFile)
|| "FNT" `isSuffixOf` T.unpack (fromJust sdlFontFile)
|| "BDF" `isSuffixOf` T.unpack (fromJust sdlFontFile)
sdlSizeAdd = fromJust $ if isBitmapFile
then sdlBitmapSizeAdd
else sdlScalableSizeAdd
boxSize <- (+ sdlSizeAdd) <$> TTF.height sfont
-- The hacky log priority 0 tells SDL frontend to init and quit at once,
-- for testing on CIs without graphics access.
if slogPriority == Just 0 then do
rf <- createRawFrontend coscreen (\_ -> return ()) (return ())
putMVar rfMVar rf
TTF.free sfont
TTF.quit
SDL.quit
else do
-- The code below fails without access to a graphics system.
SDL.initialize [SDL.InitVideo]
let screenV2 = SDL.V2 (toEnum $ rwidth coscreen * boxSize)
(toEnum $ rheight coscreen * boxSize)
windowConfig = SDL.defaultWindow {SDL.windowInitialSize = screenV2}
rendererConfig = SDL.RendererConfig
{ rendererType = if sbenchmark
then SDL.AcceleratedRenderer
else SDL.AcceleratedVSyncRenderer
, rendererTargetTexture = True
}
swindow <- SDL.createWindow title windowConfig
srenderer <- SDL.createRenderer swindow (-1) rendererConfig
let initTexture = do
texture <- SDL.createTexture srenderer SDL.ARGB8888
SDL.TextureAccessTarget screenV2
SDL.rendererRenderTarget srenderer SDL.$= Just texture
SDL.rendererDrawBlendMode srenderer SDL.$= SDL.BlendNone
SDL.rendererDrawColor srenderer SDL.$= colorToRGBA Color.Black
SDL.clear srenderer -- clear the texture
SDL.rendererRenderTarget srenderer SDL.$= Nothing
SDL.copy srenderer texture Nothing Nothing -- clear the backbuffer
return texture
texture <- initTexture
satlas <- newIORef EM.empty
stexture <- newIORef texture
spreviousFrame <- newIORef $ blankSingleFrame coscreen
sforcedShutdown <- newIORef False
scontinueSdlLoop <- newIORef True
sframeQueue <- newEmptyMVar
sframeDrawn <- newEmptyMVar
let sess = FrontendSession{..}
rfWithoutPrintScreen <-
createRawFrontend coscreen (display sess) (shutdown sess)
let rf = rfWithoutPrintScreen {fprintScreen = printScreen sess}
putMVar rfMVar rf
let pointTranslate :: forall i. (Enum i) => Vect.Point Vect.V2 i -> Point
pointTranslate (SDL.P (SDL.V2 x y)) =
Point (fromEnum x `div` boxSize) (fromEnum y `div` boxSize)
redraw = do
-- Textures may be trashed and even invalid, especially on Windows.
atlas <- readIORef satlas
writeIORef satlas EM.empty
oldTexture <- readIORef stexture
newTexture <- initTexture
mapM_ SDL.destroyTexture $ EM.elems atlas
SDL.destroyTexture oldTexture
writeIORef stexture newTexture
prevFrame <- readIORef spreviousFrame
writeIORef spreviousFrame (blankSingleFrame coscreen)
-- to overwrite each char
drawFrame soptions sess prevFrame
loopSDL :: IO ()
loopSDL = do
me <- SDL.pollEvent -- events take precedence over frames
case me of
Nothing -> do
mfr <- tryTakeMVar sframeQueue
case mfr of
Just fr -> do
-- Don't present an unchanged backbuffer.
-- This doesn't improve FPS; probably equal frames happen
-- very rarely, if at all, which is actually very good.
prevFrame <- readIORef spreviousFrame
unless (prevFrame == fr) $ do
-- Some SDL2 (OpenGL) backends are very thread-unsafe,
-- so we need to ensure we draw on the same (bound) OS thread
-- that initialized SDL, hence we have to poll frames.
drawFrame soptions sess fr
-- We can't print screen in @display@ due to thread-unsafety.
when sprintEachScreen $ printScreen sess
putMVar sframeDrawn () -- signal that drawing ended
Nothing -> threadDelay $ if sbenchmark then 150 else 15000
-- 60 polls per second, so keyboard snappy enough;
-- max 6000 FPS when benchmarking
Just e -> handleEvent e
continueSdlLoop <- readIORef scontinueSdlLoop
if continueSdlLoop
then loopSDL
else do
TTF.free sfont
TTF.quit
SDL.destroyRenderer srenderer
SDL.destroyWindow swindow
SDL.quit
forcedShutdown <- readIORef sforcedShutdown
when forcedShutdown
exitSuccess -- not in the main thread, so no exit yet, see "Main"
handleEvent e = case SDL.eventPayload e of
SDL.KeyboardEvent keyboardEvent
| SDL.keyboardEventKeyMotion keyboardEvent == SDL.Pressed -> do
let sym = SDL.keyboardEventKeysym keyboardEvent
ksm = SDL.keysymModifier sym
shiftPressed = SDL.keyModifierLeftShift ksm
|| SDL.keyModifierRightShift ksm
key = keyTranslate shiftPressed $ SDL.keysymKeycode sym
modifier = modTranslate ksm
modifierNoShift = case modifier of -- to prevent S-!, etc.
K.Shift -> K.NoModifier
K.ControlShift -> K.Control
_ -> modifier
p <- SDL.getAbsoluteMouseLocation
when (key == K.Esc) $ resetChanKey (fchanKey rf)
saveKMP rf modifierNoShift key (pointTranslate p)
SDL.MouseButtonEvent mouseButtonEvent
| SDL.mouseButtonEventMotion mouseButtonEvent == SDL.Released -> do
modifier <- modTranslate <$> SDL.getModState
let key = case SDL.mouseButtonEventButton mouseButtonEvent of
SDL.ButtonLeft -> K.LeftButtonRelease
SDL.ButtonMiddle -> K.MiddleButtonRelease
SDL.ButtonRight -> K.RightButtonRelease
_ -> K.LeftButtonRelease -- any other is spare left
p = SDL.mouseButtonEventPos mouseButtonEvent
saveKMP rf modifier key (pointTranslate p)
SDL.MouseWheelEvent mouseWheelEvent -> do
modifier <- modTranslate <$> SDL.getModState
let SDL.V2 _ y = SDL.mouseWheelEventPos mouseWheelEvent
mkey = case (compare y 0, SDL.mouseWheelEventDirection
mouseWheelEvent) of
(EQ, _) -> Nothing
(LT, SDL.ScrollNormal) -> Just K.WheelSouth
(GT, SDL.ScrollNormal) -> Just K.WheelNorth
(LT, SDL.ScrollFlipped) -> Just K.WheelNorth
(GT, SDL.ScrollFlipped) -> Just K.WheelSouth
p <- SDL.getAbsoluteMouseLocation
maybe (return ())
(\key -> saveKMP rf modifier key (pointTranslate p)) mkey
SDL.WindowClosedEvent{} -> forceShutdown sess
SDL.QuitEvent -> forceShutdown sess
SDL.WindowRestoredEvent{} -> redraw
SDL.WindowExposedEvent{} -> redraw -- needed on Windows
-- Probably not needed, because no textures nor their content lost:
-- SDL.WindowShownEvent{} -> redraw
_ -> return ()
loopSDL
shutdown :: FrontendSession -> IO ()
shutdown FrontendSession{..} = writeIORef scontinueSdlLoop False
forceShutdown :: FrontendSession -> IO ()
forceShutdown sess@FrontendSession{..} = do
writeIORef sforcedShutdown True
shutdown sess
-- | Add a frame to be drawn.
display :: FrontendSession -- ^ frontend session data
-> SingleFrame -- ^ the screen frame to draw
-> IO ()
display FrontendSession{..} curFrame = do
continueSdlLoop <- readIORef scontinueSdlLoop
if continueSdlLoop then do
putMVar sframeQueue curFrame
-- Wait until the frame is drawn.
takeMVar sframeDrawn
else do
forcedShutdown <- readIORef sforcedShutdown
when forcedShutdown $
-- When there's a forced shutdown, ignore displaying one frame
-- and don't occupy the CPU creating new ones and moving on with the game
-- (possibly also saving the new game state, surprising the player),
-- but delay the server and client thread(s) for a long time
-- and let the SDL-init thread clean up and exit via @exitSuccess@
-- to avoid exiting via "thread blocked".
threadDelay 50000
drawFrame :: ClientOptions -- ^ client options
-> FrontendSession -- ^ frontend session data
-> SingleFrame -- ^ the screen frame to draw
-> IO ()
drawFrame ClientOptions{..} FrontendSession{..} curFrame = do
let isBitmapFile = "fon" `isSuffixOf` T.unpack (fromJust sdlFontFile)
|| "fnt" `isSuffixOf` T.unpack (fromJust sdlFontFile)
|| "bdf" `isSuffixOf` T.unpack (fromJust sdlFontFile)
|| "FON" `isSuffixOf` T.unpack (fromJust sdlFontFile)
|| "FNT" `isSuffixOf` T.unpack (fromJust sdlFontFile)
|| "BDF" `isSuffixOf` T.unpack (fromJust sdlFontFile)
sdlSizeAdd = fromJust $ if isBitmapFile
then sdlBitmapSizeAdd
else sdlScalableSizeAdd
boxSize <- (+ sdlSizeAdd) <$> TTF.height sfont
let tt2 = Vect.V2 (toEnum boxSize) (toEnum boxSize)
vp :: Int -> Int -> Vect.Point Vect.V2 CInt
vp x y = Vect.P $ Vect.V2 (toEnum x) (toEnum y)
drawHighlight !x !y !color = do
SDL.rendererDrawColor srenderer SDL.$= colorToRGBA color
let rect = SDL.Rectangle (vp (x * boxSize) (y * boxSize)) tt2
SDL.drawRect srenderer $ Just rect
SDL.rendererDrawColor srenderer SDL.$= colorToRGBA Color.Black
-- reset back to black
chooseAndDrawHighlight !x !y !bg = case bg of
Color.HighlightNone -> return ()
_ -> drawHighlight x y $ Color.highlightToColor bg
setChar :: Int -> (Word32, Word32) -> IO Int
setChar !i (!w, !wPrev) | w == wPrev = return $! i + 1
setChar i (w, _) = do
atlas <- readIORef satlas
let Point{..} = toEnum i
Color.AttrChar{acAttr=Color.Attr{fg=fgRaw,bg}, acChar=acCharRaw} =
Color.attrCharFromW32 $ Color.AttrCharW32 w
fg | py `mod` 2 == 0 && fgRaw == Color.White = Color.AltWhite
| otherwise = fgRaw
ac = Color.attrChar2ToW32 fg acCharRaw
-- <https://www.libsdl.org/projects/SDL_ttf/docs/SDL_ttf_42.html#SEC42>
textTexture <- case EM.lookup ac atlas of
Nothing -> do
-- Make all visible floors bold (no bold fold variant for 16x16x,
-- so only the dot can be bold).
let acChar = if not (Color.isBright fg)
&& acCharRaw == floorSymbol -- 0xb7
then if isBitmapFile
then Char.chr 7 -- hack
else Char.chr 8901 -- 0x22c5
else acCharRaw
textSurfaceRaw <- TTF.shadedGlyph sfont (colorToRGBA fg)
(colorToRGBA Color.Black) acChar
Vect.V2 sw sh <- SDL.surfaceDimensions textSurfaceRaw
let width = min boxSize $ fromEnum sw
height = min boxSize $ fromEnum sh
xsrc = max 0 (fromEnum sw - width) `div` 2
ysrc = max 0 (fromEnum sh - height) `div` 2
srcR = SDL.Rectangle (vp xsrc ysrc)
(Vect.V2 (toEnum width) (toEnum height))
xtgt = (boxSize - width) `divUp` 2
ytgt = (boxSize - height) `div` 2
tgtR = vp xtgt ytgt
textSurface <- SDL.createRGBSurface tt2 SDL.ARGB8888
SDL.surfaceFillRect textSurface Nothing (colorToRGBA Color.Black)
-- We resize surface rather than texture to set the resulting
-- texture as @TextureAccessStatic@ via @createTextureFromSurface@,
-- which otherwise we wouldn't be able to do.
void $ SDL.surfaceBlit textSurfaceRaw (Just srcR)
textSurface (Just tgtR)
SDL.freeSurface textSurfaceRaw
textTexture <- SDL.createTextureFromSurface srenderer textSurface
SDL.freeSurface textSurface
writeIORef satlas $ EM.insert ac textTexture atlas
return textTexture
Just textTexture -> return textTexture
let tgtR = SDL.Rectangle (vp (px * boxSize) (py * boxSize)) tt2
SDL.copy srenderer textTexture Nothing (Just tgtR)
-- Potentially overwrite a portion of the glyph.
chooseAndDrawHighlight px py bg
return $! i + 1
texture <- readIORef stexture
prevFrame <- readIORef spreviousFrame
writeIORef spreviousFrame curFrame
SDL.rendererRenderTarget srenderer SDL.$= Just texture
SDL.rendererDrawColor srenderer SDL.$= colorToRGBA Color.Black
U.foldM'_ setChar 0 $ U.zip (PointArray.avector $ singleFrame curFrame)
(PointArray.avector $ singleFrame prevFrame)
SDL.rendererRenderTarget srenderer SDL.$= Nothing
SDL.copy srenderer texture Nothing Nothing -- clear the backbuffer
SDL.present srenderer
-- It can't seem to cope with SDL_PIXELFORMAT_INDEX8, so we are stuck
-- with huge bitmaps.
printScreen :: FrontendSession -> IO ()
printScreen FrontendSession{..} = do
dataDir <- appDataDir
tryCreateDir dataDir
tryCreateDir $ dataDir </> "screenshots"
utcTime <- getCurrentTime
timezone <- getTimeZone utcTime
let unspace = map $ \c -> case c of -- prevent the need for backquoting
' ' -> '_'
':' -> '.'
_ -> c
dateText = unspace $ take 25 $ show $ utcToLocalTime timezone utcTime
fileName = dataDir </> "screenshots" </> "prtscn" <> dateText <.> "bmp"
SDL.Internal.Types.Renderer renderer = srenderer
Vect.V2 sw sh <- SDL.get $ SDL.windowSize swindow
ptrOut <- SDL.Raw.Video.createRGBSurface 0 sw sh 32 0 0 0 0
surfaceOut <- peek ptrOut
void $ SDL.Raw.Video.renderReadPixels
renderer
nullPtr
SDL.Raw.Enum.SDL_PIXELFORMAT_ARGB8888
(SDL.Raw.Types.surfacePixels surfaceOut)
(sw * 4)
withCString fileName $ \fileNameCString ->
void $! SDL.Raw.Video.saveBMP ptrOut fileNameCString
SDL.Raw.Video.freeSurface ptrOut
-- | Translates modifiers to our own encoding.
modTranslate :: SDL.KeyModifier -> K.Modifier
modTranslate m =
modifierTranslate
(SDL.keyModifierLeftCtrl m || SDL.keyModifierRightCtrl m)
(SDL.keyModifierLeftShift m || SDL.keyModifierRightShift m)
(SDL.keyModifierLeftAlt m
|| SDL.keyModifierRightAlt m
|| SDL.keyModifierAltGr m)
False
keyTranslate :: Bool -> SDL.Keycode -> K.Key
keyTranslate shiftPressed n = case n of
KeycodeEscape -> K.Esc
KeycodeReturn -> K.Return
KeycodeBackspace -> K.BackSpace
KeycodeTab -> if shiftPressed then K.BackTab else K.Tab
KeycodeSpace -> K.Space
KeycodeExclaim -> K.Char '!'
KeycodeQuoteDbl -> K.Char '"'
KeycodeHash -> K.Char '#'
KeycodePercent -> K.Char '%'
KeycodeDollar -> K.Char '$'
KeycodeAmpersand -> K.Char '&'
KeycodeQuote -> if shiftPressed then K.Char '"' else K.Char '\''
KeycodeLeftParen -> K.Char '('
KeycodeRightParen -> K.Char ')'
KeycodeAsterisk -> K.Char '*'
KeycodePlus -> K.Char '+'
KeycodeComma -> if shiftPressed then K.Char '<' else K.Char ','
KeycodeMinus -> if shiftPressed then K.Char '_' else K.Char '-'
KeycodePeriod -> if shiftPressed then K.Char '>' else K.Char '.'
KeycodeSlash -> if shiftPressed then K.Char '?' else K.Char '/'
Keycode1 -> if shiftPressed then K.Char '!' else K.Char '1'
Keycode2 -> if shiftPressed then K.Char '@' else K.Char '2'
Keycode3 -> if shiftPressed then K.Char '#' else K.Char '3'
Keycode4 -> if shiftPressed then K.Char '$' else K.Char '4'
Keycode5 -> if shiftPressed then K.Char '%' else K.Char '5'
Keycode6 -> if shiftPressed then K.Char '^' else K.Char '6'
Keycode7 -> if shiftPressed then K.Char '&' else K.Char '7'
Keycode8 -> if shiftPressed then K.Char '*' else K.Char '8'
Keycode9 -> if shiftPressed then K.Char '(' else K.Char '9'
Keycode0 -> if shiftPressed then K.Char ')' else K.Char '0'
KeycodeColon -> K.Char ':'
KeycodeSemicolon -> if shiftPressed then K.Char ':' else K.Char ';'
KeycodeLess -> K.Char '<'
KeycodeEquals -> if shiftPressed then K.Char '+' else K.Char '='
KeycodeGreater -> K.Char '>'
KeycodeQuestion -> K.Char '?'
KeycodeAt -> K.Char '@'
KeycodeLeftBracket -> if shiftPressed then K.Char '{' else K.Char '['
KeycodeBackslash -> if shiftPressed then K.Char '|' else K.Char '\\'
KeycodeRightBracket -> if shiftPressed then K.Char '}' else K.Char ']'
KeycodeCaret -> K.Char '^'
KeycodeUnderscore -> K.Char '_'
KeycodeBackquote -> if shiftPressed then K.Char '~' else K.Char '`'
KeycodeUp -> K.Up
KeycodeDown -> K.Down
KeycodeLeft -> K.Left
KeycodeRight -> K.Right
KeycodeHome -> K.Home
KeycodeEnd -> K.End
KeycodePageUp -> K.PgUp
KeycodePageDown -> K.PgDn
KeycodeInsert -> K.Insert
KeycodeDelete -> K.Delete
KeycodePrintScreen -> K.PrintScreen
KeycodeClear -> K.Begin
KeycodeKPClear -> K.Begin
KeycodeKPDivide -> if shiftPressed then K.Char '?' else K.Char '/'
-- KP and normal are merged here
KeycodeKPMultiply -> K.KP '*'
KeycodeKPMinus -> K.Char '-' -- KP and normal are merged here
KeycodeKPPlus -> K.Char '+' -- KP and normal are merged here
KeycodeKPEnter -> K.Return
KeycodeKPEquals -> K.Return -- in case of some funny layouts
KeycodeKP1 -> if shiftPressed then K.KP '1' else K.End
KeycodeKP2 -> if shiftPressed then K.KP '2' else K.Down
KeycodeKP3 -> if shiftPressed then K.KP '3' else K.PgDn
KeycodeKP4 -> if shiftPressed then K.KP '4' else K.Left
KeycodeKP5 -> if shiftPressed then K.KP '5' else K.Begin
KeycodeKP6 -> if shiftPressed then K.KP '6' else K.Right
KeycodeKP7 -> if shiftPressed then K.KP '7' else K.Home
KeycodeKP8 -> if shiftPressed then K.KP '8' else K.Up
KeycodeKP9 -> if shiftPressed then K.KP '9' else K.PgUp
KeycodeKP0 -> if shiftPressed then K.KP '0' else K.Insert
KeycodeKPPeriod -> K.Char '.' -- dot and comma are merged here
KeycodeKPComma -> K.Char '.' -- to sidestep national standards
KeycodeF1 -> K.Fun 1
KeycodeF2 -> K.Fun 2
KeycodeF3 -> K.Fun 3
KeycodeF4 -> K.Fun 4
KeycodeF5 -> K.Fun 5
KeycodeF6 -> K.Fun 6
KeycodeF7 -> K.Fun 7
KeycodeF8 -> K.Fun 8
KeycodeF9 -> K.Fun 9
KeycodeF10 -> K.Fun 10
KeycodeF11 -> K.Fun 11
KeycodeF12 -> K.Fun 12
KeycodeLCtrl -> K.DeadKey
KeycodeLShift -> K.DeadKey
KeycodeLAlt -> K.DeadKey
KeycodeLGUI -> K.DeadKey
KeycodeRCtrl -> K.DeadKey
KeycodeRShift -> K.DeadKey
KeycodeRAlt -> K.DeadKey
KeycodeRGUI -> K.DeadKey
KeycodeMode -> K.DeadKey
KeycodeNumLockClear -> K.DeadKey
KeycodeUnknown -> K.Unknown "KeycodeUnknown"
_ -> let i = fromEnum $ unwrapKeycode n
in if | 97 <= i && i <= 122
&& shiftPressed -> K.Char $ Char.chr $ i - 32
| 32 <= i && i <= 126 -> K.Char $ Char.chr i
| otherwise -> K.Unknown $ show n
sDL_ALPHA_OPAQUE :: Word8
sDL_ALPHA_OPAQUE = 255
-- This code is sadly duplicated from "Game.LambdaHack.Definition.Color".
colorToRGBA :: Color.Color -> SDL.V4 Word8
colorToRGBA Color.Black = SDL.V4 0 0 0 sDL_ALPHA_OPAQUE
colorToRGBA Color.Red = SDL.V4 0xD5 0x05 0x05 sDL_ALPHA_OPAQUE
colorToRGBA Color.Green = SDL.V4 0x05 0x9D 0x05 sDL_ALPHA_OPAQUE
colorToRGBA Color.Brown = SDL.V4 0xCA 0x4A 0x05 sDL_ALPHA_OPAQUE
colorToRGBA Color.Blue = SDL.V4 0x05 0x56 0xF4 sDL_ALPHA_OPAQUE
colorToRGBA Color.Magenta = SDL.V4 0xAF 0x0E 0xAF sDL_ALPHA_OPAQUE
colorToRGBA Color.Cyan = SDL.V4 0x05 0x96 0x96 sDL_ALPHA_OPAQUE
colorToRGBA Color.White = SDL.V4 0xB8 0xBF 0xCB sDL_ALPHA_OPAQUE
colorToRGBA Color.AltWhite = SDL.V4 0xC4 0xBE 0xB1 sDL_ALPHA_OPAQUE
colorToRGBA Color.BrBlack = SDL.V4 0x6F 0x5F 0x5F sDL_ALPHA_OPAQUE
colorToRGBA Color.BrRed = SDL.V4 0xFF 0x55 0x55 sDL_ALPHA_OPAQUE
colorToRGBA Color.BrGreen = SDL.V4 0x65 0xF1 0x36 sDL_ALPHA_OPAQUE
colorToRGBA Color.BrYellow = SDL.V4 0xEB 0xD6 0x42 sDL_ALPHA_OPAQUE
colorToRGBA Color.BrBlue = SDL.V4 0x4D 0x98 0xF4 sDL_ALPHA_OPAQUE
colorToRGBA Color.BrMagenta = SDL.V4 0xFF 0x77 0xFF sDL_ALPHA_OPAQUE
colorToRGBA Color.BrCyan = SDL.V4 0x52 0xF4 0xE5 sDL_ALPHA_OPAQUE
colorToRGBA Color.BrWhite = SDL.V4 0xFF 0xFF 0xFF sDL_ALPHA_OPAQUE