-- | 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 =  -- to prevent S-!, etc.
                  if modifier == K.Shift then K.NoModifier else 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