content: -- | 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.Storable as VS
  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 (die, 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.Event
  import qualified SDL.Raw.Types
  import qualified SDL.Raw.Video
  import qualified SDL.Vect as Vect
  
  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.Client.UI.Overlay
  import           Game.LambdaHack.Client.UI.PointUI
  import           Game.LambdaHack.Common.ClientOptions
  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
  
  -- These are needed until SDL is fixed and all our devs move
  -- to the fixed version:
  import           Control.Monad.IO.Class (MonadIO, liftIO)
  import           SDL.Internal.Exception (throwIfNull)
  import qualified SDL.Raw.Event as Raw
  import           Unsafe.Coerce (unsafeCoerce)
  --import qualified SDL.Raw.Enum as Raw
  
  type FontAtlas = EM.EnumMap Color.AttrCharW32 SDL.Texture
  
  -- | Session data maintained by the frontend.
  data FrontendSession = FrontendSession
    { swindow          :: SDL.Window
    , srenderer        :: SDL.Renderer
    , squareFont       :: TTF.Font
    , squareFontSize   :: Int
    , mapFontIsBitmap  :: Bool
    , spropFont        :: Maybe TTF.Font
    , sboldFont        :: Maybe TTF.Font
    , smonoFont        :: Maybe TTF.Font
    , squareAtlas      :: IORef FontAtlas
    , smonoAtlas       :: IORef FontAtlas
    , sbasicTexture    :: IORef SDL.Texture
    , 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
   TTF.initialize
   let title = T.pack $ fromJust stitle
       chosenFontsetID = fromJust schosenFontset
   -- Unlike @error@, @die@ does not move savefiles aside.
   chosenFontset <- case lookup chosenFontsetID sfontsets of
     Nothing -> die $ "Fontset not defined in config file"
                      `showFailure` chosenFontsetID
     Just fs -> return fs
       -- If some auxiliary fonts are equal and at the same size, this wastefully
       -- opens them many times. However, native builds are efficient enough
       -- and slow machines should use the most frugal case (only square font)
       -- in which no waste occurs and all rendering is aided with an atlas.
   let findFontFile t =
         if T.null t
         then return Nothing
         else case lookup t sfonts of
           Nothing -> die $ "Font not defined in config file" `showFailure` t
           Just (FontProportional fname fsize fhint) -> do
             sdlFont <- loadFontFile fname fsize
             setHintMode sdlFont fhint
             -- TODO: when SDL_ttf can do it, check that not a bitmap font
             realSize <- TTF.height sdlFont
             let !_A = assert (realSize > 0) ()  -- sanity
             return $ Just (sdlFont, realSize)
           Just (FontMonospace fname fsize fhint) -> do
             sdlFont <- loadFontFile fname fsize
             setHintMode sdlFont fhint
             isFontMono <- TTF.isMonospace sdlFont
             realSize <- TTF.height sdlFont
             let !_A = assert (isFontMono && realSize > 0) ()  -- sanity
             return $ Just (sdlFont, realSize)
           Just (FontMapScalable fname fsize fhint cellSizeAdd) -> do
             sdlFont <- loadFontFile fname fsize
             setHintMode sdlFont fhint
             isFontMono <- TTF.isMonospace sdlFont
             realSize <- TTF.height sdlFont
             let !_A = assert (isFontMono && realSize > 0) ()  -- sanity
             return $ Just (sdlFont, realSize + cellSizeAdd)
           Just (FontMapBitmap fname cellSizeAdd) -> do
             sdlFont <- loadFontFile fname 0  -- size ignored for bitmap fonts
             isFontMono <- TTF.isMonospace sdlFont
             realSize <- TTF.height sdlFont
             let !_A = assert (isFontMono && realSize > 0) ()  -- sanity
             return $ Just (sdlFont, realSize + cellSizeAdd)
       loadFontFile fname fsize = do
         let fontFileName = T.unpack fname
             fontSize = round $ fromJust sallFontsScale * intToDouble fsize
         if isRelative fontFileName
         then do
           case lookup fontFileName $ rFontFiles coscreen of
             Nothing -> fail $ "Font file not supplied with the game: "
                               ++ fontFileName
                               ++ " within "
                               ++ show (map fst $ rFontFiles coscreen)
             Just bs -> TTF.decode bs fontSize
         else do
           fontFileExists <- doesFileExist fontFileName
           if not fontFileExists
           then fail $ "Font file does not exist: " ++ fontFileName
           else TTF.load fontFileName fontSize
       setHintMode _ HintingHeavy = return ()  -- default
       setHintMode sdlFont HintingLight = TTF.setHinting sdlFont TTF.Light
   (squareFont, squareFontSize, mapFontIsBitmap) <-
     if fromJust sallFontsScale == 1.0 then do
       mfontMapBitmap <- findFontFile $ fontMapBitmap chosenFontset
       case mfontMapBitmap of
         Just (sdlFont, size) -> return (sdlFont, size, True)
         Nothing -> do
           mfontMapScalable <- findFontFile $ fontMapScalable chosenFontset
           case mfontMapScalable of
             Just (sdlFont, size) -> return (sdlFont, size, False)
             Nothing -> die "Neither bitmap nor scalable map font defined"
     else do
       mfontMapScalable <- findFontFile $ fontMapScalable chosenFontset
       case mfontMapScalable of
          Just (sdlFont, size) -> return (sdlFont, size, False)
          Nothing -> die "Scaling requested but scalable map font not defined"
   let halfSize = squareFontSize `div` 2
       boxSize = 2 * halfSize  -- map font determines cell size for all others
   -- Real size of these fonts ignored.
   spropFont <- fst <$$> findFontFile (fontPropRegular chosenFontset)
   sboldFont <- fst <$$> findFontFile (fontPropBold chosenFontset)
   smonoFont <- fst <$$> findFontFile (fontMono chosenFontset)
   let !_A =
         assert
           (isJust spropFont && isJust sboldFont && isJust smonoFont
            || isNothing spropFont && isNothing sboldFont && isNothing smonoFont
            `blame` "Either all auxiliary fonts should be defined or none"
            `swith` chosenFontset) ()
   -- 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
    maybe (return ()) TTF.free spropFont
    maybe (return ()) TTF.free sboldFont
    maybe (return ()) TTF.free smonoFont
    TTF.free squareFont
    TTF.quit
    SDL.quit
   else do
    -- The code below fails without access to a graphics system.
    SDL.initialize [SDL.InitVideo]
    -- This cursor size if fine for default size and Full HD 1.5x size.
    let (cursorAlpha, cursorBW) = cursorXhair
    xhairCursor <-
      createCursor cursorBW cursorAlpha (SDL.V2 32 27) (SDL.P (SDL.V2 13 13))
    SDL.activeCursor SDL.$= xhairCursor
  --  xhairCursor <-
  --    throwIfNull "SDL.Input.Mouse.createSystemCursor" "SDL_createSystemCursor"
  --    $ Raw.createSystemCursor Raw.SDL_SYSTEM_CURSOR_CROSSHAIR
  --  SDL.activeCursor SDL.$= unsafeCoerce xhairCursor
    let screenV2 = SDL.V2 (toEnum $ rwidth coscreen * boxSize)
                          (toEnum $ rheight coscreen * boxSize)
        windowConfig = SDL.defaultWindow
          { SDL.windowInitialSize = screenV2
          , SDL.windowMode = case fromMaybe NotFullscreen sfullscreenMode of
              ModeChange -> SDL.Fullscreen
              BigBorderlessWindow -> SDL.FullscreenDesktop
              NotFullscreen -> SDL.Windowed
          , SDL.windowResizable = False  -- the default, but just in case...
          , SDL.windowHighDPI = True  -- possibly prevents resize for Retina
          }
        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
    unless (fromMaybe NotFullscreen sfullscreenMode == NotFullscreen) $
      -- This is essential to preserve game map aspect ratio in fullscreen, etc.,
      -- if the aspect ratios of video mode and game map view don't match.
      SDL.rendererLogicalSize srenderer SDL.$= Just screenV2
    let clearScreen = do
          -- Display black screen ASAP to hide any garbage. This is also needed
          -- to clear trash on the margins in fullscreen. No idea why the double
          -- calls are needed, sometimes. Perhaps it's double-buffered.
          SDL.rendererRenderTarget srenderer SDL.$= Nothing
          SDL.clear srenderer  -- clear the backbuffer
          SDL.present srenderer
          SDL.clear srenderer  -- clear the other half of the double buffer?
          SDL.present srenderer
    clearScreen
    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.$= blackRGBA
          SDL.clear srenderer  -- clear the texture
          return texture
    basicTexture <- initTexture
    sbasicTexture <- newIORef basicTexture
    texture <- initTexture
    stexture <- newIORef texture
    squareAtlas <- newIORef EM.empty
    smonoAtlas <- newIORef EM.empty
    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 -> PointUI
        pointTranslate (SDL.P (SDL.V2 x y)) =
          PointUI (fromEnum x `div` halfSize) (fromEnum y `div` boxSize)
        redraw = do
          -- Textures may be trashed and even invalid, especially on Windows.
          atlas <- readIORef squareAtlas
          writeIORef squareAtlas EM.empty
          monoAtlas <- readIORef smonoAtlas
          writeIORef smonoAtlas EM.empty
          oldBasicTexture <- readIORef sbasicTexture
          newBasicTexture <- initTexture
          oldTexture <- readIORef stexture
          newTexture <- initTexture
          mapM_ SDL.destroyTexture $ EM.elems atlas
          mapM_ SDL.destroyTexture $ EM.elems monoAtlas
          SDL.destroyTexture oldBasicTexture
          SDL.destroyTexture oldTexture
          writeIORef sbasicTexture newBasicTexture
          writeIORef stexture newTexture
          -- To clear the margins in fullscreen:
          clearScreen
          -- To overwrite each char:
          prevFrame <- readIORef spreviousFrame
          writeIORef spreviousFrame $ blankSingleFrame coscreen
          drawFrame coscreen soptions sess prevFrame
          SDL.pumpEvents
          SDL.Raw.Event.flushEvents minBound maxBound
        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
                  -- 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 coscreen soptions sess fr
                  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
            maybe (return ()) TTF.free spropFont
            maybe (return ()) TTF.free sboldFont
            maybe (return ()) TTF.free smonoFont
            TTF.free squareFont
            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
                    K.AltShift -> K.Alt
                    _ -> 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  -- e.g., unminimize
          SDL.WindowExposedEvent{} -> redraw  -- needed on Windows
          SDL.WindowResizedEvent{} ->
            -- Some window managers apparently are able to resize.
            -- And some send resize events at startup, even though
            -- they don't resize eventually, so this is too much spam:
            -- SDL.showSimpleMessageBox Nothing SDL.Warning
            --  "Windows resize detected"
            --  "Please resize the game and/or make it fullscreen via 'allFontsScale' and 'fullscreenMode' settings in the 'config.ui.ini' file. Resizing fonts via generic scaling algorithms gives poor results."
            redraw
          -- Probably not needed, because no textures nor their content lost:
          -- SDL.WindowShownEvent{} -> redraw
          _ -> return ()
    loopSDL
  
  -- | Copied from SDL2 and fixed (packed booleans are needed).
  --
  -- Create a cursor using the specified bitmap data and mask (in MSB format,
  -- packed). Width must be a multiple of 8.
  --
  --
  createCursor :: MonadIO m
               => VS.Vector Word8 -- ^ Whether this part of the cursor is black. Use bit 1 for white and bit 0 for black.
               -> VS.Vector Word8 -- ^ Whether or not pixels are visible. Use bit 1 for visible and bit 0 for transparent.
               -> Vect.V2 CInt -- ^ The width and height of the cursor.
               -> Vect.Point Vect.V2 CInt -- ^ The X- and Y-axis location of the upper left corner of the cursor relative to the actual mouse position
               -> m SDL.Cursor
  createCursor dta msk (Vect.V2 w h) (Vect.P (Vect.V2 hx hy)) =
      liftIO . fmap unsafeCoerce $
          throwIfNull "SDL.Input.Mouse.createCursor" "SDL_createCursor" $
              VS.unsafeWith dta $ \unsafeDta ->
              VS.unsafeWith msk $ \unsafeMsk ->
                  Raw.createCursor unsafeDta unsafeMsk w h hx hy
  
  -- Ignores bits after the last 8 multiple.
  boolListToWord8List :: [Bool] -> [Word8]
  boolListToWord8List =
    let i True multiple = multiple
        i False _ = 0
    in \case
      b1 : b2 : b3 : b4 : b5 : b6 : b7 : b8 : rest ->
        i b1 128 + i b2 64 + i b3 32 + i b4 16 + i b5 8 + i b6 4 + i b7 2 + i b8 1
        : boolListToWord8List rest
      _ -> []
  
  cursorXhair :: (VS.Vector Word8, VS.Vector Word8)  -- alpha, BW
  cursorXhair =
    let charToBool '.' = (True, True)  -- visible black
        charToBool '#' = (True, False)  -- visible white
        charToBool _ = (False, False)  -- transparent white
        toVS = VS.fromList . boolListToWord8List
    in toVS *** toVS $ unzip $ map charToBool $ concat
  
      [ "            ...                 "
      , "            .#.                 "
      , "        ..  .#.  ..             "
      , "      ..##  .#.  ##..           "
      , "     .##    .#.    ##.          "
      , "    .#      .#.      #.         "
      , "   .#       .#.       #.        "
      , "   .#       ...       #.        "
      , "  .#                   #.       "
      , "  .#                   #.       "
      , "                                "
      , "             .                  "
      , "........    .#.    ........     "
      , ".######.   .###.   .######.     "
      , "........    .#.    ........     "
      , "             .                  "
      , "                                "
      , "  .#                   #.       "
      , "  .#                   #.       "
      , "   .#       ...       #.        "
      , "   .#       .#.       #.        "
      , "    .#      .#.      #.         "
      , "     .##    .#.    ##.          "
      , "      ..##  .#.  ##..           "
      , "        ..  .#.  ..             "
      , "            .#.                 "
      , "            ...                 " ]
  
  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 :: ScreenContent    -- ^ e.g., game screen size
            -> ClientOptions    -- ^ client options
            -> FrontendSession  -- ^ frontend session data
            -> SingleFrame      -- ^ the screen frame to draw
            -> IO ()
  drawFrame coscreen ClientOptions{..} sess@FrontendSession{..} curFrame = do
    prevFrame <- readIORef spreviousFrame
    let halfSize = squareFontSize `div` 2
        boxSize = 2 * halfSize
        tt2Square = 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 !col !row !color = do
          SDL.rendererDrawColor srenderer SDL.$= colorToRGBA color
          let rect = SDL.Rectangle (vp (col * boxSize) (row * boxSize)) tt2Square
          SDL.drawRect srenderer $ Just rect
          SDL.rendererDrawColor srenderer SDL.$= blackRGBA
            -- reset back to black
        chooseAndDrawHighlight !col !row !bg = do
  -- Rectangle drawing is broken in SDL 2.0.16
  -- (https://github.com/LambdaHack/LambdaHack/issues/281)
  -- and simple workarounds fail with old SDL, e.g., four lines instead of
  -- a rectangle, so we have to manually erase the broken rectangles
  -- instead of depending on glyphs overwriting them fully.
         let workaroundOverwriteHighlight = do
               let rect = SDL.Rectangle (vp (col * boxSize) (row * boxSize))
                                        tt2Square
               SDL.drawRect srenderer $ Just rect
         case bg of
          Color.HighlightNone -> workaroundOverwriteHighlight
          Color.HighlightBackground -> workaroundOverwriteHighlight
          Color.HighlightNoneCursor -> workaroundOverwriteHighlight
          _ -> drawHighlight col row $ Color.highlightToColor bg
  -- workarounds end
        -- This also frees the surface it gets.
        scaleSurfaceToTexture :: Int -> SDL.Surface -> IO SDL.Texture
        scaleSurfaceToTexture xsize textSurfaceRaw = do
          Vect.V2 sw sh <- SDL.surfaceDimensions textSurfaceRaw
          let width = min xsize $ fromEnum sw
              height = min boxSize $ fromEnum sh
              xsrc = max 0 (fromEnum sw - width) `div` 2
              ysrc = max 0 (fromEnum sh - height) `divUp` 2
              srcR = SDL.Rectangle (vp xsrc ysrc)
                                   (Vect.V2 (toEnum width) (toEnum height))
              xtgt = (xsize - width) `divUp` 2
              ytgt = (boxSize - height) `div` 2
              tgtR = vp xtgt ytgt
              tt2 = Vect.V2 (toEnum xsize) (toEnum boxSize)
          textSurface <- SDL.createRGBSurface tt2 SDL.ARGB8888
          SDL.surfaceFillRect textSurface Nothing blackRGBA
          -- We crop 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
          return textTexture
        -- This also frees the surface it gets.
        scaleSurfaceToTextureProp :: Int -> Int -> SDL.Surface -> Bool
                                  -> IO (Int, SDL.Texture)
        scaleSurfaceToTextureProp x row textSurfaceRaw allSpace = do
          Vect.V2 sw sh <- SDL.surfaceDimensions textSurfaceRaw
          let widthRaw = fromEnum sw
              remainingWidth = rwidth coscreen * boxSize - x
              width | widthRaw <= remainingWidth = widthRaw
                    | allSpace = remainingWidth
                    | otherwise = remainingWidth - boxSize
              height = min boxSize $ fromEnum sh
              xsrc = 0
              ysrc = max 0 (fromEnum sh - height) `divUp` 2
              srcR = SDL.Rectangle (vp xsrc ysrc)
                                   (Vect.V2 (toEnum width) (toEnum height))
              xtgt = 0
              ytgt = (boxSize - height) `div` 2
              tgtR = vp xtgt ytgt
              tt2Prop = Vect.V2 (toEnum width) (toEnum boxSize)
          textSurface <- SDL.createRGBSurface tt2Prop SDL.ARGB8888
          SDL.surfaceFillRect textSurface Nothing blackRGBA
          -- We crop surface rather than texture to set the resulting
          -- texture as @TextureAccessStatic@ via @createTextureFromSurface@,
          -- which otherwise we wouldn't be able to do.
          -- This is not essential for proportional font, for which we have
          -- no texture atlas, but it's consistent with other fonts
          -- and the bottleneck is the square font, anyway.
          void $ SDL.surfaceBlit textSurfaceRaw (Just srcR)
                                 textSurface (Just tgtR)
          SDL.freeSurface textSurfaceRaw
          textTexture <- SDL.createTextureFromSurface srenderer textSurface
          SDL.freeSurface textSurface
          when (width /= widthRaw && not allSpace) $
            setSquareChar (rwidth coscreen - 1) row Color.trimmedLineAttrW32
          return (width, textTexture)
        -- <https://www.libsdl.org/projects/SDL_ttf/docs/SDL_ttf_42.html#SEC42>
        -- Note that @Point@ here refers to screen coordinates with square font
        -- (as @PointSquare@ normally should) and not game map coordinates.
        -- See "Game.LambdaHack.Client.UI.Frame" for explanation of this
        -- irregularity.
        setMapChar :: PointI -> (Word32, Word32) -> IO Int
        setMapChar !i (!w, !wPrev) =
          if w == wPrev
          then return $! i + 1
          else do
            let Point{..} = toEnum i
            setSquareChar px py (Color.AttrCharW32 w)
            return $! i + 1
        drawMonoOverlay :: OverlaySpace -> IO ()
        drawMonoOverlay =
          mapM_ (\(PointUI x y, al) ->
                   let lineCut = take (2 * rwidth coscreen - x) al
                   in drawMonoLine x y lineCut)
        drawMonoLine :: Int -> Int -> AttrString -> IO ()
        drawMonoLine _ _ [] = return ()
        drawMonoLine x row (w : rest) = do
          setMonoChar x row w
          drawMonoLine (x + 1) row rest
        setMonoChar :: Int -> Int -> Color.AttrCharW32 -> IO ()
        setMonoChar !x !row !w = do
          atlas <- readIORef smonoAtlas
          let Color.AttrChar{acAttr=Color.Attr{fg=fgRaw, bg}, acChar} =
                Color.attrCharFromW32 w
              fg | even row && fgRaw == Color.White = Color.AltWhite
                 | otherwise = fgRaw
              ac = Color.attrChar2ToW32 fg acChar
              !_A = assert (bg `elem` [ Color.HighlightNone
                                      , Color.HighlightNoneCursor ]) ()
          textTexture <- case EM.lookup ac atlas of
            Nothing -> do
              textSurfaceRaw <-
                TTF.shadedGlyph (fromJust smonoFont) (colorToRGBA fg)
                                blackRGBA acChar
              textTexture <- scaleSurfaceToTexture halfSize textSurfaceRaw
              writeIORef smonoAtlas $ EM.insert ac textTexture atlas
              return textTexture
            Just textTexture -> return textTexture
          let tt2Mono = Vect.V2 (toEnum halfSize) (toEnum boxSize)
              tgtR = SDL.Rectangle (vp (x * halfSize) (row * boxSize)) tt2Mono
          SDL.copy srenderer textTexture Nothing (Just tgtR)
        drawSquareOverlay :: OverlaySpace -> IO ()
        drawSquareOverlay =
          mapM_ (\(pUI, al) ->
                   let PointSquare col row = uiToSquare pUI
                       lineCut = take (rwidth coscreen - col) al
                   in drawSquareLine col row lineCut)
        drawSquareLine :: Int -> Int -> AttrString -> IO ()
        drawSquareLine _ _ [] = return ()
        drawSquareLine col row (w : rest) = do
          setSquareChar col row w
          drawSquareLine (col + 1) row rest
        setSquareChar :: Int -> Int -> Color.AttrCharW32 -> IO ()
        setSquareChar !col !row !w = do
          atlas <- readIORef squareAtlas
          let Color.AttrChar{ acAttr=Color.Attr{fg=fgRaw, bg}
                            , acChar=acCharRaw } =
                Color.attrCharFromW32 w
              fg | even row && fgRaw == Color.White = Color.AltWhite
                 | otherwise = fgRaw
              ac = if bg == Color.HighlightBackground
                   then w
                   else Color.attrChar2ToW32 fg acCharRaw
          textTexture <- case EM.lookup ac atlas of
            Nothing -> do
              -- Make all visible floors bold (no bold font variant for 16x16x,
              -- so only the dot can be bold).
              let acChar = if not (Color.isBright fg)
                              && acCharRaw == floorSymbol  -- '\x00B7'
                           then if mapFontIsBitmap
                                then '\x0007'
                                else '\x22C5'
                           else acCharRaw
                  background = if bg == Color.HighlightBackground
                               then greyRGBA
                               else blackRGBA
              textSurfaceRaw <- TTF.shadedGlyph squareFont (colorToRGBA fg)
                                                background acChar
              textTexture <- scaleSurfaceToTexture boxSize textSurfaceRaw
              writeIORef squareAtlas $ EM.insert ac textTexture atlas
              return textTexture
            Just textTexture -> return textTexture
          let tgtR = SDL.Rectangle (vp (col * boxSize) (row * boxSize)) tt2Square
          SDL.copy srenderer textTexture Nothing (Just tgtR)
          -- Potentially overwrite a portion of the glyph.
          chooseAndDrawHighlight col row bg
        drawPropOverlay :: OverlaySpace -> IO ()
        drawPropOverlay =
          mapM_ (\(PointUI x y, al) ->
                   drawPropLine (x * halfSize) y al)
        drawPropLine :: Int -> Int -> AttrString -> IO ()
        drawPropLine _ _ [] = return ()
        drawPropLine x _ _ | x >= (rwidth coscreen - 1) * boxSize =
          -- This chunk starts at $ sign or beyond so, for KISS, reject it.
          return ()
        drawPropLine x row (w : rest) = do
          let isSpace = (== Color.spaceAttrW32)
              Color.AttrChar{acAttr=Color.Attr{fg=fgRaw, bg}} =
                Color.attrCharFromW32
                $ if isSpace w
                  then case filter (not . isSpace) rest of
                    w2 : _ -> w2
                    [] -> w
                  else w
              sameAttr ac = Color.fgFromW32 ac == fgRaw
                            || isSpace ac  -- matches all colours
              (sameRest, otherRest) = span sameAttr rest
              !_A = assert (bg `elem` [ Color.HighlightNone
                                      , Color.HighlightNoneCursor ]) ()
              fg | even row && fgRaw == Color.White = Color.AltWhite
                 | otherwise = fgRaw
              t = T.pack . attrStringToString  $ w : sameRest
          width <- drawPropChunk x row fg t
          drawPropLine (x + width) row otherRest
        drawPropChunk :: Int -> Int -> Color.Color -> T.Text -> IO Int
        drawPropChunk x row fg t = do
          let font = if fg >= Color.White && fg /= Color.BrBlack
                     then spropFont
                     else sboldFont
              allSpace = T.all Char.isSpace t
          textSurfaceRaw <- TTF.shaded (fromJust font) (colorToRGBA fg)
                                       blackRGBA t
          (width, textTexture) <-
            scaleSurfaceToTextureProp x row textSurfaceRaw allSpace
          let tgtR = SDL.Rectangle (vp x (row * boxSize))
                                   (Vect.V2 (toEnum width) (toEnum boxSize))
          -- Potentially overwrite some of the screen.
          SDL.copy srenderer textTexture Nothing (Just tgtR)
          SDL.destroyTexture textTexture
          return width
    let arraysEqual = singleArray curFrame == singleArray prevFrame
        overlaysEqual =
          singleMonoOverlay curFrame == singleMonoOverlay prevFrame
          && singleSquareOverlay curFrame == singleSquareOverlay prevFrame
          && singlePropOverlay curFrame == singlePropOverlay prevFrame
    basicTexture <- readIORef sbasicTexture  -- previous content still present
    unless arraysEqual $ do
      SDL.rendererRenderTarget srenderer SDL.$= Just basicTexture
      U.foldM'_ setMapChar 0 $ U.zip (PointArray.avector $ singleArray curFrame)
                                     (PointArray.avector $ singleArray prevFrame)
    unless (arraysEqual && overlaysEqual) $ do
      texture <- readIORef stexture
      SDL.rendererRenderTarget srenderer SDL.$= Just texture
      SDL.copy srenderer basicTexture Nothing Nothing  -- overwrite last content
      -- Mono overlay rendered last, because more likely to come after
      -- the proportional one and so to have a warning message about overrun
      -- that needs to be overlaid on top of the proportional overlay.
      drawPropOverlay $ singlePropOverlay curFrame
      drawSquareOverlay $ singleSquareOverlay curFrame
      drawMonoOverlay $ singleMonoOverlay curFrame
      writeIORef spreviousFrame curFrame
      SDL.rendererRenderTarget srenderer SDL.$= Nothing
      SDL.copy srenderer texture Nothing Nothing  -- overwrite the backbuffer
      SDL.present srenderer
      -- We can't print screen in @display@ due to thread-unsafety.
      when sprintEachScreen $ printScreen sess
  
  -- 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
       || SDL.keyModifierLeftGUI m
       || SDL.keyModifierRightGUI 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 '`'
    Keycode 167      -> if shiftPressed then K.Char '~' else K.Char '`'
      -- on some keyboards the key below ESC is paragraph and its scancode is 167
      -- and moreover SDL sometimes gives this code even on normal keyboards
    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.Char '*'  -- KP and normal are merged here
    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
  
  blackRGBA :: SDL.V4 Word8
  blackRGBA = SDL.V4 0 0 0 sDL_ALPHA_OPAQUE
  
  -- A third of @colorToRGBA Color.BrBlack@ to compensate for the use
  -- as background (high area) as opposed to glyphs (usually small area).
  greyRGBA :: SDL.V4 Word8
  greyRGBA = SDL.V4 0x25 0x1F 0x1F sDL_ALPHA_OPAQUE
  
  -- This code is sadly duplicated from "Game.LambdaHack.Definition.Color".
  colorToRGBA :: Color.Color -> SDL.V4 Word8
  colorToRGBA Color.Black     = blackRGBA
  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
  